fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Code DRY cleaning

Browse Source
This commit is contained in:
Steffen Jost 2019-05-17 13:53:07 +02:00
parent 601cbeab76
commit c0bc4dd8f3
1 changed files with 16 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Handler/Utils.hs
View File

@ -38,6 +38,7 @@ import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
-- | Check whether the user's preference for files is inline-viewing or downloading
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do downloadFiles = do
mauth <- liftHandlerT maybeAuth mauth <- liftHandlerT maybeAuth
@ -47,18 +48,22 @@ downloadFiles = do
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles return userDefaultDownloadFiles
-- | Simply send a `File`-Value
sendThisFile :: File -> Handler TypedContent
sendThisFile File{..}
| Just fileContent' <- fileContent = do
ifM downloadFiles
(addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|])
(addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|])
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise = sendResponseStatus noContent204 ()
-- | Serve a single file, identified through a given DB query -- | Serve a single file, identified through a given DB query
serveOneFile :: DB [Entity File] -> Handler TypedContent serveOneFile :: DB [Entity File] -> Handler TypedContent
serveOneFile query = do serveOneFile query = do
results <- runDB query results <- runDB query
case results of case results of
[Entity _fileId File{fileTitle, fileContent}] [Entity _fileId file] -> sendThisFile file
| Just fileContent' <- fileContent -> do
ifM downloadFiles
(addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|])
(addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|])
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
[] -> notFound [] -> notFound
other -> do other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
@ -70,19 +75,13 @@ serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent
serveSomeFiles archiveName query = do serveSomeFiles archiveName query = do
results <- runDB query results <- runDB query
case results of case results of
[] -> notFound [] -> notFound
[Entity _fileId File{fileTitle, fileContent}] [Entity _fileId file] -> sendThisFile file
| Just fileContent' <- fileContent -> do moreFiles -> do
ifM downloadFiles
(addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|])
(addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|])
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
files -> do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
let zipComment = T.encodeUtf8 archiveName let zipComment = T.encodeUtf8 archiveName
yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder yieldMany moreFiles .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
tidFromText :: Text -> Maybe TermId tidFromText :: Text -> Maybe TermId