{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Hledger.Web.Handler.UploadR
  ( getUploadR
  , postUploadR
  ) where

import Control.Monad.Except (runExceptT)
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, writeJournalTextIfValidAndChanged)

uploadForm :: FilePath -> Markup -> MForm Handler (FormResult FileInfo, Widget)
uploadForm :: String -> Markup -> MForm Handler (FormResult FileInfo, Widget)
uploadForm String
f =
  Text
-> (Markup
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
         Enctype
         Ints
         Handler
         (FormResult FileInfo, WidgetFor (HandlerSite Handler) ()))
-> Markup
-> RWST
     (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
     Enctype
     Ints
     Handler
     (FormResult FileInfo, WidgetFor (HandlerSite Handler) ())
forall (m :: * -> *) a.
Monad m =>
Text
-> (Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
identifyForm Text
"upload" ((Markup
  -> RWST
       (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
       Enctype
       Ints
       Handler
       (FormResult FileInfo, WidgetFor (HandlerSite Handler) ()))
 -> Markup
 -> RWST
      (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
      Enctype
      Ints
      Handler
      (FormResult FileInfo, WidgetFor (HandlerSite Handler) ()))
-> (Markup
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
         Enctype
         Ints
         Handler
         (FormResult FileInfo, WidgetFor (HandlerSite Handler) ()))
-> Markup
-> RWST
     (Maybe (Env, FileEnv), HandlerSite Handler, [Text])
     Enctype
     Ints
     Handler
     (FormResult FileInfo, WidgetFor (HandlerSite Handler) ())
forall a b. (a -> b) -> a -> b
$ \Markup
extra -> do
    (FormResult FileInfo
res, FieldView (HandlerSite Handler)
_) <- Field Handler FileInfo
-> FieldSettings (HandlerSite Handler)
-> Maybe FileInfo
-> MForm
     Handler (FormResult FileInfo, FieldView (HandlerSite Handler))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field Handler FileInfo
forall (m :: * -> *). Monad m => Field m FileInfo
fileField FieldSettings (HandlerSite Handler)
forall {master}. FieldSettings master
fs Maybe FileInfo
forall a. Maybe a
Nothing
    -- Ignoring the view - setting the name of the element is enough here
    (FormResult FileInfo, Widget)
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     Handler
     (FormResult FileInfo, Widget)
forall a.
a
-> RWST (Maybe (Env, FileEnv), App, [Text]) Enctype Ints Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormResult FileInfo
res, $(widgetFile "upload-form"))
  where
    fs :: FieldSettings master
fs = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"file" Maybe (SomeMessage master)
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"file") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"file") []

getUploadR :: FilePath -> Handler ()
getUploadR :: String -> Handler ()
getUploadR String
f = do
  Handler ()
checkServerSideUiEnabled
  String -> Handler ()
postUploadR String
f

postUploadR :: FilePath -> Handler ()
postUploadR :: String -> Handler ()
postUploadR String
f = do
  Handler ()
checkServerSideUiEnabled
  VD {Journal
j :: Journal
j :: ViewData -> Journal
j} <- Handler ViewData
getViewData
  Permission -> Handler ()
require Permission
EditPermission

  (String
f', Text
_) <- String -> Journal -> HandlerFor App (String, Text)
forall m. String -> Journal -> HandlerFor m (String, Text)
journalFile404 String
f Journal
j
  ((FormResult FileInfo
res, Widget
view), Enctype
enctype) <- (Markup -> MForm Handler (FormResult FileInfo, Widget))
-> HandlerFor App ((FormResult FileInfo, Widget), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadResource m,
 MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost (String -> Markup -> MForm Handler (FormResult FileInfo, Widget)
uploadForm String
f')
  FileInfo
fi <- HandlerFor App FileInfo
-> FormResult FileInfo -> HandlerFor App FileInfo
forall (m :: * -> *) a. Applicative m => m a -> FormResult a -> m a
fromFormSuccess (Widget -> Enctype -> HandlerFor App FileInfo
forall {site} {a} {a} {c}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site c
showForm Widget
view Enctype
enctype) FormResult FileInfo
res
  ByteString
lbs <- ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> HandlerFor App ByteString -> HandlerFor App ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () ByteString Handler ()
-> ConduitT ByteString Void Handler ByteString
-> HandlerFor App ByteString
forall (m :: * -> *) a r.
Monad m =>
ConduitT () a m () -> ConduitT a Void m r -> m r
connect (FileInfo -> ConduitT () ByteString Handler ()
forall (m :: * -> *).
MonadResource m =>
FileInfo -> ConduitT () ByteString m ()
fileSource FileInfo
fi) ConduitT ByteString Void Handler ByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m ByteString
sinkLbs

  -- Try to parse as UTF-8
  -- XXX Unfortunate - how to parse as system locale?
  Text
newtxt <- case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
lbs of
    Left UnicodeException
e -> do
      Markup -> Handler ()
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage (Markup -> Handler ()) -> Markup -> Handler ()
forall a b. (a -> b) -> a -> b
$
        Markup
"Encoding error: '" Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> String -> Markup
forall a. ToMarkup a => a -> Markup
toHtml (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e) Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> Markup
"'. " Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<>
        Markup
"If your file is not UTF-8 encoded, try the 'edit form', " Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<>
        Markup
"where the transcoding should be handled by the browser."
      Widget -> Enctype -> HandlerFor App Text
forall {site} {a} {a} {c}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site c
showForm Widget
view Enctype
enctype
    Right Text
newtxt -> Text -> HandlerFor App Text
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
newtxt
  ExceptT String Handler () -> HandlerFor App (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (String -> Text -> ExceptT String Handler ()
forall (m :: * -> *).
MonadHandler m =>
String -> Text -> ExceptT String m ()
writeJournalTextIfValidAndChanged String
f Text
newtxt) HandlerFor App (Either String ())
-> (Either String () -> Handler ()) -> Handler ()
forall a b.
HandlerFor App a -> (a -> HandlerFor App b) -> HandlerFor App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
e -> do
      Markup -> Handler ()
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage (Markup -> Handler ()) -> Markup -> Handler ()
forall a b. (a -> b) -> a -> b
$ Markup
"Failed to load journal: " Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> String -> Markup
forall a. ToMarkup a => a -> Markup
toHtml String
e
      Widget -> Enctype -> Handler ()
forall {site} {a} {a} {c}.
(Yesod site, ToMarkup a, ToWidget site a) =>
a -> a -> HandlerFor site c
showForm Widget
view Enctype
enctype
    Right () -> do
      Markup -> Handler ()
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage (Markup -> Handler ()) -> Markup -> Handler ()
forall a b. (a -> b) -> a -> b
$ Markup
"File " Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> String -> Markup
forall a. ToMarkup a => a -> Markup
toHtml String
f Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> Markup
" uploaded successfully"
      Route App -> Handler ()
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route App
JournalR
  where
    showForm :: a -> a -> HandlerFor site c
showForm a
view a
enctype =
      Markup -> HandlerFor site c
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse (Markup -> HandlerFor site c)
-> (WidgetFor site () -> HandlerFor site Markup)
-> WidgetFor site ()
-> HandlerFor site c
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< WidgetFor site () -> HandlerFor site Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor site () -> HandlerFor site c)
-> WidgetFor site () -> HandlerFor site c
forall a b. (a -> b) -> a -> b
$ do
        Markup -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
"Upload journal"
        WidgetFor site ()
[whamlet|<form method=post enctype=#{enctype}>^{view}|]