From 74b373d23d35446d772d6bb2b01c49ca38978236 Mon Sep 17 00:00:00 2001 From: Daniel Schadt 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.hs | 203 ++++++++++++++++++++++++++++++ src/ImageHoster/Data.hs | 88 +++++++++++++ src/ImageHoster/Monad.hs | 81 ++++++++++++ src/Lib.hs | 313 ----------------------------------------------- 4 files changed, 372 insertions(+), 313 deletions(-) create mode 100644 src/ImageHoster.hs create mode 100644 src/ImageHoster/Data.hs create mode 100644 src/ImageHoster/Monad.hs delete mode 100644 src/Lib.hs (limited to 'src') diff --git a/src/ImageHoster.hs b/src/ImageHoster.hs new file mode 100644 index 0000000..b2db71d --- /dev/null +++ b/src/ImageHoster.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Description : Simple image hosting +Copyright : (c) Daniel, 2020 +License : BSD-3 +Maintainer : kingdread@gmx.de +-} + +module ImageHoster + ( -- * Submodules + module ImageHoster.Data + , module ImageHoster.Monad + -- * Entry points + , imgHostMain + , handleUpload + , handleCleanup + -- * Other functions + , checkAuthorization + , randomName + , validChars + , indexPage + , getImageData + , saveFile + ) where + +import ImageHoster.Data +import ImageHoster.Monad + +import Data.ByteString.Char8 (pack) +import Control.Applicative +import Control.Monad +import Crypto.BCrypt +import Data.Aeson +import Data.FileEmbed +import Data.Maybe +import Data.Time.Clock.System +import Network.CGI +import System.Directory +import System.FilePath +import System.Random + +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BS + +-- | HTML source code of the index page. +-- +-- This is included at compile time from @src/index.html@. +indexPage :: String +indexPage = $(embedStringFile "src/index.html") + + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe = either (const Nothing) Just + + +chooseRandom :: (RandomGen g) => [a] -> g -> (a, g) +chooseRandom inp gen = let (idx, nextGen) = randomR (0, length inp - 1) gen in + (inp !! idx, nextGen) + + +-- | Valid characters for filename creation. +validChars :: String +validChars = ['a'..'z'] ++ ['A'..'Z'] + + +-- | Creates a random filename. +-- +-- This uses the IO standard random generator to generate a name. +randomName :: App String +randomName = settings' nameLength >>= \l -> + mapM (\_ -> liftIO $ getStdRandom (chooseRandom validChars)) [1..l] + + +-- | Save the given file in the correct output directory. +saveFile :: BS.ByteString + -- ^ The file content to be saved, i.e. the image data. + -> String + -- ^ The file extension (including dot), or an empty string. + -> Seconds + -- ^ The duration until the file should expire, or 0. + -> String + -- ^ The user name of the user that saved the file. + -> App String + -- ^ Returns the file name that was used to save the file. +saveFile content extension duration username = do + filename <- (++ extension) <$> randomName + dir <- settings' outputDir + let outputPath = dir filename + liftIO $ BS.writeFile outputPath content + currentTime <- liftIO getSystemTime + let eol = currentTime { systemSeconds = systemSeconds currentTime + fromInteger duration } + metadata = Metadata { creator = username + , createdAt = toInteger $ systemSeconds currentTime + , endOfLife = toInteger $ systemSeconds eol + } + liftIO $ BS.writeFile (outputPath ++ ".meta") (encode metadata) + return filename + + +-- | Check the authorization data. +checkAuthorization :: [(String, String)] + -- ^ The (user, password) list. + -> Maybe String + -- ^ The given username. + -> Maybe String + -- ^ The given password. + -> Bool + -- ^ The authorization result. +checkAuthorization us (Just user) (Just password) = case lookup user us of + Just p -> validatePassword (pack p) (pack password) + Nothing -> False +checkAuthorization _ _ _ = False + + +-- | Get the image data from the current request. +-- +-- This first checks if some raw content is given in the @imagecontent@ field +-- (i.e. data from a pasted image), and afterwards checks @imagefile@ (i.e. the +-- file selected in the file chooser). +getImageData :: App (Maybe BS.ByteString) +getImageData = do + rawData <- getInputFPS "imagecontent" + case rawData of + Just d | d /= "" -> return . rightToMaybe $ B64.decode d + _ -> getInputFPS "imagefile" + + +cleanupFile :: FilePath -> App () +cleanupFile fname = do + dir <- settings' outputDir + currentTime <- systemSeconds <$> liftIO getSystemTime + content <- liftIO $ BS.readFile (dir fname) + case decode content :: (Maybe Metadata) of + Just metadata | isEternal metadata -> return () + Just metadata | endOfLife metadata < toInteger currentTime -> do + logCGI ("Deleting " ++ fname) + liftIO $ removeFile (dir fname) + liftIO $ removeFile (dir takeBaseName fname) + _ -> return () + + +-- | Performs the cleanup by deleting expired images. +handleCleanup :: App CGIResult +handleCleanup = do + dir <- settings' outputDir + files <- liftIO $ getDirectoryContents dir + let metaFiles = filter ((== ".meta") . takeExtension) files + forM_ metaFiles cleanupFile + output "Cleaning up" + + +-- | Performs a file upload. +handleUpload :: App CGIResult +handleUpload = do + us <- settings' users + outdir <- settings' outputDir + user <- getInput "username" + password <- getInput "password" + let authorized = checkAuthorization us user password + if authorized then do + filecontent <- getImageData + filename <- getInputFilename "imagefile" + duration :: Maybe Integer <- readInput "duration" + let finfo = (,,) <$> filecontent <*> (filename <|> Just "") <*> duration + case finfo of + Just (content, name, dur) -> do + savedFileName <- saveFile content (takeExtension name) dur (fromJust user) + redirect $ outdir savedFileName + Nothing -> do + setStatus 400 "Missing data" + output "Invalid request" + else do + setStatus 401 "Unauthorized" + output "Invalid credentials" + +-- | Main entry point of the application. +-- +-- Depending on the given parameters, this either dispatches to +-- 'handleCleanup', 'handleUpload' or just returns the 'indexPage'. +imgHostMain :: App CGIResult +imgHostMain = dispatch [ (doCleanup, handleCleanup) + , (doUpload, handleUpload) + , (doDefault, output indexPage) + ] + where + dispatch :: [(App Bool, App CGIResult)] -> App CGIResult + dispatch ((c, a):as) = do + take_that <- c + if take_that then a + else dispatch as + dispatch [] = do + setStatus 500 "Internal Server Error" + output "No dispatch could be done :(" + + doCleanup :: App Bool + doCleanup = isJust <$> getInput "cleanup" + doUpload :: App Bool + doUpload = ("POST" ==) <$> requestMethod + doDefault :: App Bool + doDefault = return True 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 diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index 5a48f3f..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} - -{-| -Description : Simple image hosting -Copyright : (c) Daniel, 2020 -License : BSD-3 -Maintainer : kingdread@gmx.de --} - -module Lib - ( -- * Data structures - App - , runApp - , Settings(..) - , defaultSettings - , Metadata(..) - , Seconds - -- * Entry points - , imgHostMain - , handleUpload - , handleCleanup - -- * Other functions - , checkAuthorization - , randomName - , validChars - , indexPage - , ask - , asks - , getImageData - , saveFile - ) where - - -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. --- --- This is included at compile time from @src/index.html@. -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 - - -chooseRandom :: (RandomGen g) => [a] -> g -> (a, g) -chooseRandom inp gen = let (idx, nextGen) = randomR (0, length inp - 1) gen in - (inp !! idx, nextGen) - - --- | Valid characters for filename creation. -validChars :: String -validChars = ['a'..'z'] ++ ['A'..'Z'] - - --- | Creates a random filename. --- --- This uses the IO standard random generator to generate a name. -randomName :: App String -randomName = asks nameLength >>= \l -> - mapM (\_ -> liftIO $ getStdRandom (chooseRandom validChars)) [1..l] - - --- | Save the given file in the correct output directory. -saveFile :: BS.ByteString - -- ^ The file content to be saved, i.e. the image data. - -> String - -- ^ The file extension (including dot), or an empty string. - -> Seconds - -- ^ The duration until the file should expire, or 0. - -> String - -- ^ The user name of the user that saved the file. - -> App String - -- ^ Returns the file name that was used to save the file. -saveFile content extension duration username = do - filename <- (++ extension) <$> randomName - dir <- asks outputDir - let outputPath = dir filename - liftIO $ BS.writeFile outputPath content - currentTime <- liftIO getSystemTime - let eol = currentTime { systemSeconds = systemSeconds currentTime + fromInteger duration } - metadata = Metadata { creator = username - , createdAt = toInteger $ systemSeconds currentTime - , endOfLife = toInteger $ systemSeconds eol - } - liftIO $ BS.writeFile (outputPath ++ ".meta") (encode metadata) - return filename - - --- | Check the authorization data. -checkAuthorization :: [(String, String)] - -- ^ The (user, password) list. - -> Maybe String - -- ^ The given username. - -> Maybe 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 _ _ _ = False - - --- | Get the image data from the current request. --- --- This first checks if some raw content is given in the @imagecontent@ field --- (i.e. data from a pasted image), and afterwards checks @imagefile@ (i.e. the --- file selected in the file chooser). -getImageData :: App (Maybe BS.ByteString) -getImageData = do - rawData <- getInputFPS "imagecontent" - case rawData of - Just d | d /= "" -> return . rightToMaybe $ B64.decode d - _ -> getInputFPS "imagefile" - - -cleanupFile :: FilePath -> App () -cleanupFile fname = do - dir <- asks outputDir - currentTime <- systemSeconds <$> liftIO getSystemTime - content <- liftIO $ BS.readFile (dir fname) - case decode content :: (Maybe Metadata) of - Just metadata | isEternal metadata -> return () - Just metadata | endOfLife metadata < toInteger currentTime -> do - logCGI ("Deleting " ++ fname) - liftIO $ removeFile (dir fname) - liftIO $ removeFile (dir takeBaseName fname) - _ -> return () - - --- | Performs the cleanup by deleting expired images. -handleCleanup :: App CGIResult -handleCleanup = do - dir <- asks outputDir - files <- liftIO $ getDirectoryContents dir - let metaFiles = filter ((== ".meta") . takeExtension) files - forM_ metaFiles cleanupFile - output "Cleaning up" - - --- | Performs a file upload. -handleUpload :: App CGIResult -handleUpload = do - users <- asks users - outdir <- asks outputDir - user <- getInput "username" - password <- getInput "password" - let authorized = checkAuthorization users user password - if authorized then do - filecontent <- getImageData - filename <- getInputFilename "imagefile" - duration :: Maybe Integer <- readInput "duration" - let finfo = (,,) <$> filecontent <*> (filename <|> Just "") <*> duration - case finfo of - Just (content, name, dur) -> do - savedFileName <- saveFile content (takeExtension name) dur (fromJust user) - redirect $ outdir savedFileName - Nothing -> do - setStatus 400 "Missing data" - output "Invalid request" - else do - setStatus 401 "Unauthorized" - output "Invalid credentials" - --- | Main entry point of the application. --- --- Depending on the given parameters, this either dispatches to --- 'handleCleanup', 'handleUpload' or just returns the 'indexPage'. -imgHostMain :: App CGIResult -imgHostMain = dispatch [ (doCleanup, handleCleanup) - , (doUpload, handleUpload) - , (doDefault, output indexPage) - ] - where - dispatch :: [(App Bool, App CGIResult)] -> App CGIResult - dispatch ((c, a):as) = do - take_that <- c - if take_that then a - else dispatch as - dispatch [] = do - setStatus 500 "Internal Server Error" - output "No dispatch could be done :(" - - doCleanup :: App Bool - doCleanup = isJust <$> getInput "cleanup" - doUpload :: App Bool - doUpload = ("POST" ==) <$> requestMethod - doDefault :: App Bool - doDefault = return True -- cgit v1.2.3