{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Web.Handler.UploadR
( getUploadR
, postUploadR
) where
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (connect)
import Data.Conduit.Binary (sinkLbs)
import qualified Data.Text.Encoding as TE
import Hledger.Web.Import
import Hledger.Web.Widget.Common (fromFormSuccess, journalFile404, writeValidJournal)
uploadForm :: FilePath -> Markup -> MForm Handler (FormResult FileInfo, Widget)
uploadForm f =
identifyForm "upload" $ \extra -> do
(res, _) <- mreq fileField fs Nothing
pure (res, $(widgetFile "upload-form"))
where
fs = FieldSettings "file" Nothing (Just "file") (Just "file") []
getUploadR :: FilePath -> Handler ()
getUploadR = postUploadR
postUploadR :: FilePath -> Handler ()
postUploadR f = do
VD {caps, j} <- getViewData
when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
(f', _) <- journalFile404 f j
((res, view), enctype) <- runFormPost (uploadForm f')
fi <- fromFormSuccess (showForm view enctype) res
lbs <- BL.toStrict <$> connect (fileSource fi) sinkLbs
text <- case TE.decodeUtf8' lbs of
Left e -> do
setMessage $
"Encoding error: '" <> toHtml (show e) <> "'. " <>
"If your file is not UTF-8 encoded, try the 'edit form', " <>
"where the transcoding should be handled by the browser."
showForm view enctype
Right text -> return text
writeValidJournal f text >>= \case
Left e -> do
setMessage $ "Failed to load journal: " <> toHtml e
showForm view enctype
Right () -> do
setMessage $ "File " <> toHtml f <> " uploaded successfully"
redirect JournalR
where
showForm view enctype =
sendResponse <=< defaultLayout $ do
setTitle "Upload journal"
[whamlet|<form method=post enctype=#{enctype}>^{view}|]