From 74b373d23d35446d772d6bb2b01c49ca38978236 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Tue, 3 Mar 2020 14:24:18 +0100
Subject: reorganize module

This switches some definitions around and wraps App in a newtype, in
preparation for more cleanup.
---
 src/ImageHoster/Data.hs  | 88 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/ImageHoster/Monad.hs | 81 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 169 insertions(+)
 create mode 100644 src/ImageHoster/Data.hs
 create mode 100644 src/ImageHoster/Monad.hs

(limited to 'src/ImageHoster')

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
-- 
cgit v1.2.3