reorganize module

This switches some definitions around and wraps App in a newtype, in
preparation for more cleanup.

3 files changed, 185 insertions, 126 deletions

diff --git a/src/Lib.hs b/src/ImageHoster.hs
index 5a48f3f..b2db71d 100644
--- a/src/Lib.hs
+++ b/src/ImageHoster.hs
@@ -1,9 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
 
 {-|
 Description : Simple image hosting
@@ -12,14 +9,10 @@ License     : BSD-3
 Maintainer  : kingdread@gmx.de
 -}
 
-module Lib
-    ( -- * Data structures
-      App
-    , runApp
-    , Settings(..)
-    , defaultSettings
-    , Metadata(..)
-    , Seconds
+module ImageHoster
+    ( -- * Submodules
+      module ImageHoster.Data
+    , module ImageHoster.Monad
       -- * Entry points
     , imgHostMain
     , handleUpload
@@ -29,114 +22,28 @@ module Lib
     , randomName
     , validChars
     , indexPage
-    , ask
-    , asks
     , getImageData
     , saveFile
     ) where
 
+import ImageHoster.Data
+import ImageHoster.Monad
 
 import Data.ByteString.Char8 (pack)
 import Control.Applicative
 import Control.Monad
-import Control.Monad.Reader hiding (ask, asks)
 import Crypto.BCrypt
 import Data.Aeson
-import Data.Aeson.Types
 import Data.FileEmbed
 import Data.Maybe
 import Data.Time.Clock.System
-import Data.Traversable
-import GHC.Generics
 import Network.CGI
 import System.Directory
 import System.FilePath
 import System.Random
 
-import qualified Control.Monad.Reader
 import qualified Data.ByteString.Base64.Lazy as B64
 import qualified Data.ByteString.Lazy as BS
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Text as T
-
--- | We are dealing with seconds when talking about durations, hence the type
--- alias.
-type Seconds = Integer
-
-
--- | Metadata of a stored file.
-data Metadata = Metadata { creator :: String
-                         -- ^ Username of the creator.
-                         , createdAt :: Integer
-                         -- ^ Unix timestamp of the creation time.
-                         , endOfLife :: Integer
-                         -- ^ Unix timestamp of the expiration time.
-                         } deriving (Show, Eq, Generic, FromJSON, ToJSON)
-
-isEternal :: Metadata -> Bool
-isEternal Metadata{..} = createdAt == endOfLife
-
-
--- | Application settings, should be read from a file at startup.
-data Settings = Settings { outputDir :: FilePath
-                         -- ^ Output directory for new images.
-                         , defaultDuration :: Seconds
-                         -- ^ Default lifetime of new images.
-                         , nameLength :: Int
-                         -- ^ Length (in characters) of the random identifier for images.
-                         , users :: [(String, String)]
-                         -- ^ A list of (user, password) pairs.
-                         --
-                         -- Passwords are expected to be hashed using bcrypt.
-                         } deriving (Show)
-
-
-instance FromJSON Settings where
-    parseJSON = withObject "settings" $ \o -> do
-        outputDir <- o .:? "outputDir" .!= "img"
-        defaultDuration <- o .:? "defaultDuration" .!= 0
-        nameLength <- o .:? "nameLength" .!= 20
-        users <- (o .:? "users" .!= object []) >>= parseUserDict
-        return Settings{..}
-
-
-parseUserDict :: Value -> Parser [(String, String)]
-parseUserDict =
-    withObject "users" $ \o ->
-        for (HM.toList o) $ \(user, pw) -> do
-            password <- parseJSON pw
-            return (T.unpack user, password)
-
-
-instance ToJSON Settings where
-    toJSON Settings{..} = object [ "outputDir" .= outputDir
-                                 , "defaultTimeout" .= defaultDuration
-                                 , "nameLength" .= nameLength
-                                 , "users" .= formatUsers users
-                                 ]
-        where
-            formatUsers :: [(String, String)] -> Object
-            formatUsers = HM.fromList . map (\(user, pw) -> (T.pack user, toJSON pw))
-
-
--- | Return the default settings.
-defaultSettings :: Settings
-defaultSettings =  case fromJSON $ object [] of
-                     Success a -> a
-                     Error s -> error s
-
-
--- | The application monad stack.
---
--- This includes the CGI monad, IO and a reader to access the (global)
--- application settings.
-type App a = CGIT (ReaderT Settings IO) a
-
-
--- | Run the given 'App' with the given 'Settings'.
-runApp :: Settings -> App CGIResult -> IO ()
-runApp settings app = runReaderT (runCGI (handleErrors app)) settings
-
 
 -- | HTML source code of the index page.
 --
@@ -145,23 +52,6 @@ indexPage :: String
 indexPage = $(embedStringFile "src/index.html")
 
 
--- | A lifted version of 'Control.Monad.Reader.ask'.
---
--- Provides access to the 'Settings' instance in the 'App' monad stack.
-ask :: App Settings
-ask = lift Control.Monad.Reader.ask
-
-
--- | A lifted version of 'Control.Monad.Reader.asks'.
---
--- Provides access to the 'Settings' instance, but applies a function before
--- returning the value:
---
--- > directory <- asks outputDir
-asks :: (Settings -> a) -> App a
-asks f = fmap f ask
-
-
 rightToMaybe :: Either a b -> Maybe b
 rightToMaybe = either (const Nothing) Just
 
@@ -180,7 +70,7 @@ validChars = ['a'..'z'] ++ ['A'..'Z']
 --
 -- This uses the IO standard random generator to generate a name.
 randomName :: App String
-randomName = asks nameLength >>= \l ->
+randomName = settings' nameLength >>= \l ->
     mapM (\_ -> liftIO $ getStdRandom (chooseRandom validChars)) [1..l]
 
 
@@ -197,7 +87,7 @@ saveFile :: BS.ByteString
          -- ^ Returns the file name that was used to save the file.
 saveFile content extension duration username = do
     filename <- (++ extension) <$> randomName
-    dir <- asks outputDir
+    dir <- settings' outputDir
     let outputPath = dir </> filename
     liftIO $ BS.writeFile outputPath content
     currentTime <- liftIO getSystemTime
@@ -219,9 +109,9 @@ checkAuthorization :: [(String, String)]
                    -- ^ The given password.
                    -> Bool
                    -- ^ The authorization result.
-checkAuthorization users (Just user) (Just password) = case lookup user users of
-                                                         Just p -> validatePassword (pack p) (pack password)
-                                                         Nothing -> False
+checkAuthorization us (Just user) (Just password) = case lookup user us of
+                                                      Just p -> validatePassword (pack p) (pack password)
+                                                      Nothing -> False
 checkAuthorization _ _ _ = False
 
 
@@ -240,7 +130,7 @@ getImageData = do
 
 cleanupFile :: FilePath -> App ()
 cleanupFile fname = do
-    dir <- asks outputDir
+    dir <- settings' outputDir
     currentTime <- systemSeconds <$> liftIO getSystemTime
     content <- liftIO $ BS.readFile (dir </> fname)
     case decode content :: (Maybe Metadata) of
@@ -255,7 +145,7 @@ cleanupFile fname = do
 -- | Performs the cleanup by deleting expired images.
 handleCleanup :: App CGIResult
 handleCleanup = do
-    dir <- asks outputDir
+    dir <- settings' outputDir
     files <- liftIO $ getDirectoryContents dir
     let metaFiles = filter ((== ".meta") . takeExtension) files
     forM_ metaFiles cleanupFile
@@ -265,11 +155,11 @@ handleCleanup = do
 -- | Performs a file upload.
 handleUpload :: App CGIResult
 handleUpload = do
-    users <- asks users
-    outdir <- asks outputDir
+    us <- settings' users
+    outdir <- settings' outputDir
     user <- getInput "username"
     password <- getInput "password"
-    let authorized = checkAuthorization users user password
+    let authorized = checkAuthorization us user password
     if authorized then do
         filecontent <- getImageData
         filename <- getInputFilename "imagefile"
diff --git a/src/ImageHoster/Data.hs b/src/ImageHoster/Data.hs
new file mode 100644
index 0000000..39f14e0
--- /dev/null
+++ b/src/ImageHoster/Data.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module ImageHoster.Data
+    ( Settings(..)
+    , Seconds
+    , Metadata(..)
+    , isEternal
+    , defaultSettings
+    ) where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Traversable
+import GHC.Generics
+
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+
+
+-- | We are dealing with seconds when talking about durations, hence the type
+-- alias.
+type Seconds = Integer
+
+
+-- | Metadata of a stored file.
+data Metadata = Metadata { creator :: String
+                         -- ^ Username of the creator.
+                         , createdAt :: Integer
+                         -- ^ Unix timestamp of the creation time.
+                         , endOfLife :: Integer
+                         -- ^ Unix timestamp of the expiration time.
+                         } deriving (Show, Eq, Generic, FromJSON, ToJSON)
+
+
+isEternal :: Metadata -> Bool
+isEternal Metadata{..} = createdAt == endOfLife
+
+
+-- | Application settings, should be read from a file at startup.
+data Settings = Settings { outputDir :: FilePath
+                         -- ^ Output directory for new images.
+                         , defaultDuration :: Seconds
+                         -- ^ Default lifetime of new images.
+                         , nameLength :: Int
+                         -- ^ Length (in characters) of the random identifier for images.
+                         , users :: [(String, String)]
+                         -- ^ A list of (user, password) pairs.
+                         --
+                         -- Passwords are expected to be hashed using bcrypt.
+                         } deriving (Show)
+
+
+instance FromJSON Settings where
+    parseJSON = withObject "settings" $ \o -> do
+        outputDir <- o .:? "outputDir" .!= "img"
+        defaultDuration <- o .:? "defaultDuration" .!= 0
+        nameLength <- o .:? "nameLength" .!= 20
+        users <- (o .:? "users" .!= object []) >>= parseUserDict
+        return Settings{..}
+
+
+parseUserDict :: Value -> Parser [(String, String)]
+parseUserDict =
+    withObject "users" $ \o ->
+        for (HM.toList o) $ \(user, pw) -> do
+            password <- parseJSON pw
+            return (T.unpack user, password)
+
+
+instance ToJSON Settings where
+    toJSON Settings{..} = object [ "outputDir" .= outputDir
+                                 , "defaultTimeout" .= defaultDuration
+                                 , "nameLength" .= nameLength
+                                 , "users" .= formatUsers users
+                                 ]
+        where
+            formatUsers :: [(String, String)] -> Object
+            formatUsers = HM.fromList . map (\(user, pw) -> (T.pack user, toJSON pw))
+
+
+-- | Return the default settings.
+defaultSettings :: Settings
+defaultSettings =  case fromJSON $ object [] of
+                     Success a -> a
+                     Error s -> error s
diff --git a/src/ImageHoster/Monad.hs b/src/ImageHoster/Monad.hs
new file mode 100644
index 0000000..a05d59d
--- /dev/null
+++ b/src/ImageHoster/Monad.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module ImageHoster.Monad
+    ( -- * Data constructors
+      App(..)
+    , FallibleApp
+      -- * Conversion functions
+    , runFallibleApp
+    , liftApp
+    , run
+      -- * Data accessors
+    , settings
+    , settings'
+    ) where
+
+import ImageHoster.Data
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Network.CGI
+import Network.CGI.Monad
+
+-- | General type for application computations.
+--
+-- This provides:
+--
+--   * Access to a global `Settings` instance
+--   * IO computations
+--   * CGI operations
+newtype App a = App { runApp :: ReaderT Settings (CGIT IO) a }
+    deriving (Functor, Applicative, Monad)
+
+
+instance MonadCGI App where
+    cgiAddHeader k v = App . lift $ cgiAddHeader k v
+    cgiGet s = App . lift $ cgiGet s
+
+
+instance MonadIO App where
+    liftIO = App . liftIO
+
+
+-- | Type for application computations that can fail.
+--
+-- Computation stops after the first failing computation, e.g. 'Maybe'
+-- semantics.
+type FallibleApp = MaybeT App
+
+
+-- | Run a 'FallibleApp' and return the result wrapped in a 'Maybe'.
+runFallibleApp :: FallibleApp a -> App (Maybe a)
+runFallibleApp = runMaybeT
+
+
+-- | Lift an 'App' to a 'FallibleApp' that never fails.
+liftApp :: App a -> FallibleApp a
+liftApp a = MaybeT $ Just <$> a
+
+
+-- | Run a complete application using the given 'Settings'.
+run :: App CGIResult -> Settings -> IO ()
+run a s = runCGI $ runReaderT (runApp a) s
+
+
+-- | A lifted version of 'Control.Monad.Reader.ask'.
+--
+-- Provides access to the 'Settings' instance in the 'App' monad stack.
+settings :: App Settings
+settings = App ask
+
+
+-- | A lifted version of 'Control.Monad.Reader.asks'.
+--
+-- Provides access to the 'Settings' instance, but applies a function before
+-- returning the value:
+--
+-- > directory <- asks outputDir
+settings' :: (Settings -> a) -> App a
+settings' f = fmap f settings