aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ImageHoster.hs (renamed from src/Lib.hs)142
-rw-r--r--src/ImageHoster/Data.hs88
-rw-r--r--src/ImageHoster/Monad.hs81
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-26 13:04:14 +0000