rewrite handleUpload

This way we avoid the right-drift that we introduced in the first
version, as the error handling and propagation is done in the Maybe
monad.

The downside to this is that we lose some error information: We cannot
show anymore if the authorization failed or something else went wrong,
because in all cases we just bail out with Nothing.

2 files changed, 31 insertions, 29 deletions

diff --git a/src/ImageHoster.hs b/src/ImageHoster.hs
index b2db71d..e37b4d3 100644
--- a/src/ImageHoster.hs
+++ b/src/ImageHoster.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
 
 {-|
 Description : Simple image hosting
@@ -103,16 +104,15 @@ saveFile content extension duration username = do
 -- | Check the authorization data.
 checkAuthorization :: [(String, String)]
                    -- ^ The (user, password) list.
-                   -> Maybe String
+                   -> String
                    -- ^ The given username.
-                   -> Maybe String
+                   -> 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
+checkAuthorization us user password = case lookup user us of
+                                        Just p -> validatePassword (pack p) (pack password)
+                                        Nothing -> False
 
 
 -- | Get the image data from the current request.
@@ -120,8 +120,8 @@ checkAuthorization _ _ _ = False
 -- 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
+getImageData :: FallibleApp BS.ByteString
+getImageData = fallible $ do
     rawData <- getInputFPS "imagecontent"
     case rawData of
       Just d | d /= "" -> return . rightToMaybe $ B64.decode d
@@ -152,29 +152,25 @@ handleCleanup = do
     output "Cleaning up"
 
 
+handleUpload' :: FallibleApp CGIResult
+handleUpload' = do
+    us <- liftApp $ settings' users
+    outdir <- liftApp $ settings' outputDir
+    user <- fallible $ getInput "username"
+    password <- fallible $ getInput "password"
+    guard $ checkAuthorization us user password
+    filecontent <- getImageData
+    filename <- (fallible $ getInputFilename "imagefile") <|> return ""
+    duration :: Integer <- fallible $ readInput "duration"
+    savedFileName <- liftApp $ saveFile filecontent (takeExtension filename) duration user
+    liftApp . redirect $ outdir </> savedFileName
+
+
 -- | 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"
+handleUpload = runFallibleApp handleUpload' >>= \case
+    Just r -> return r
+    Nothing -> setStatus 400 "Invalid request" >> output "The upload failed"
 
 -- | Main entry point of the application.
 --
diff --git a/src/ImageHoster/Monad.hs b/src/ImageHoster/Monad.hs
index a05d59d..198ebd5 100644
--- a/src/ImageHoster/Monad.hs
+++ b/src/ImageHoster/Monad.hs
@@ -7,6 +7,7 @@ module ImageHoster.Monad
     , FallibleApp
       -- * Conversion functions
     , runFallibleApp
+    , fallible
     , liftApp
     , run
       -- * Data accessors
@@ -54,6 +55,11 @@ runFallibleApp :: FallibleApp a -> App (Maybe a)
 runFallibleApp = runMaybeT
 
 
+-- | Ensure that a computation that can fail runs as a 'FallibleApp'.
+fallible :: App (Maybe a) -> FallibleApp a
+fallible = MaybeT
+
+
 -- | Lift an 'App' to a 'FallibleApp' that never fails.
 liftApp :: App a -> FallibleApp a
 liftApp a = MaybeT $ Just <$> a