diff options
| -rw-r--r-- | app/Main.hs | 6 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/ImageHoster.hs (renamed from src/Lib.hs) | 142 | ||||
| -rw-r--r-- | src/ImageHoster/Data.hs | 88 | ||||
| -rw-r--r-- | src/ImageHoster/Monad.hs | 81 |
5 files changed, 188 insertions, 130 deletions
diff --git a/app/Main.hs b/app/Main.hs index 46bd5a3..c67fe9c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main where -import Lib +import ImageHoster import Control.Exception import Data.Aeson import Data.Maybe @@ -14,6 +14,4 @@ loadSettings = do main :: IO () -main = do - settings <- loadSettings - runApp settings imgHostMain +main = loadSettings >>= run imgHostMain diff --git a/package.yaml b/package.yaml index 73c27dd..a8d6248 100644 --- a/package.yaml +++ b/package.yaml @@ -34,6 +34,7 @@ dependencies: - bcrypt - base64-bytestring - directory +- transformers library: source-dirs: src 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 |