{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}

-- | handlers
module SnelstartImport.Web.Handler
  ( getRootR
  , postRootR
  )
where

import Data.Vector(toList)
import qualified Data.ByteString.Lazy as LBS
import SnelstartImport.Convert
import SnelstartImport.ING
import SnelstartImport.Web.Routes
import SnelstartImport.N26
import Text.Blaze.Html(Html)
import Yesod.Form
import Yesod.Core.Widget
import Yesod.Core.Handler
import Data.Text(Text, pack)
import Data.Text.Encoding
import Data.ByteString.Base64
import Data.Base64.Types(extractBase64)
import qualified Data.Text as Text
import SnelstartImport.SepaDirectCoreScheme(readSepaDirectCoreScheme, sdcrRows, sdcrGlob  )
import SnelstartImport.Web.Layout(layout)
import Yesod.Core(lucius)
import SnelstartImport.Web.Message
import Data.Time
import Control.Monad.IO.Class(liftIO)
import Data.Maybe(fromMaybe)


type Form a = Html -> MForm Handler (FormResult a, Widget)


data InputFileForm = InputFileForm {
  InputFileForm -> Text
ifBank :: Text ,
  InputFileForm -> FileInfo
ifFileInfo :: FileInfo
  }

inputFileForm :: Form InputFileForm
inputFileForm :: Form InputFileForm
inputFileForm Markup
csrf = do
  (FormResult (Maybe Text)
bankRes, FieldView (HandlerSite Handler)
bankView) <- Field Handler Text
-> FieldSettings (HandlerSite Handler)
-> Maybe (Maybe Text)
-> MForm
     Handler (FormResult (Maybe Text), FieldView (HandlerSite Handler))
forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field Handler Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField FieldSettings (HandlerSite Handler)
"own bank account" Maybe (Maybe Text)
forall a. Maybe a
Nothing
  (FormResult FileInfo
inputRes, FieldView (HandlerSite Handler)
inputView) <- 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)
"xml file" Maybe FileInfo
forall a. Maybe a
Nothing

  let view :: WidgetFor App ()
view = do
       (RY App -> Css) -> WidgetFor App ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ App) =>
(RY App -> Css) -> m ()
toWidget RY App -> Css
[lucius|
          form label {
            width: 100%;
            display: inline-block;
          }
          form input{
            margin-bottom: 1em;
          }
       |]
       WidgetFor App ()
[whamlet|
        ^{csrf}
        <div>
          <label for=#{fvId bankView}>_{MsgOwnBank}
          ^{fvInput bankView}
        <div>
          <label for=#{fvId bankView}>_{MsgXmlFile}
          ^{fvInput inputView}
        <div>
          <button type=submit >_{MsgConvert}
  |]
  (FormResult InputFileForm, WidgetFor App ())
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     Handler
     (FormResult InputFileForm, WidgetFor App ())
forall a.
a
-> RWST (Maybe (Env, FileEnv), App, [Text]) Enctype Ints Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FormResult InputFileForm, WidgetFor App ())
 -> RWST
      (Maybe (Env, FileEnv), App, [Text])
      Enctype
      Ints
      Handler
      (FormResult InputFileForm, WidgetFor App ()))
-> (FormResult InputFileForm, WidgetFor App ())
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     Handler
     (FormResult InputFileForm, WidgetFor App ())
forall a b. (a -> b) -> a -> b
$ (Text -> FileInfo -> InputFileForm
InputFileForm (Text -> FileInfo -> InputFileForm)
-> FormResult Text -> FormResult (FileInfo -> InputFileForm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
" " Text
"" (Text -> Text) -> (Maybe Text -> Text) -> Maybe Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> (Maybe Text -> Text) -> Maybe Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> FormResult (Maybe Text) -> FormResult Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult (Maybe Text)
bankRes) FormResult (FileInfo -> InputFileForm)
-> FormResult FileInfo -> FormResult InputFileForm
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult FileInfo
inputRes, WidgetFor App ()
view)

getRootR :: Handler Html
getRootR :: Handler Markup
getRootR = do
  ((FormResult InputFileForm
_res, WidgetFor App ()
form), Enctype
enctype) <- Form InputFileForm
-> HandlerFor
     App ((FormResult InputFileForm, WidgetFor App ()), 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 Form InputFileForm
inputFileForm
  WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [] Enctype
enctype WidgetFor App ()
form

inputForm :: [Text] -> Enctype -> Widget -> Widget
inputForm :: [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [Text]
issues Enctype
enctype WidgetFor App ()
form =
  let
    issuesWidget :: WidgetFor App ()
issuesWidget = if [Text] -> HasLeadingSpace
forall a. [a] -> HasLeadingSpace
forall (t :: * -> *) a. Foldable t => t a -> HasLeadingSpace
Prelude.null [Text]
issues then WidgetFor App ()
"" else
      WidgetFor App ()
[whamlet|
        <ul>
          $forall issue <- issues
            <li> #{issue}
      |]
  in

  WidgetFor App ()
[whamlet|
<h1>_{MsgTitle}
^{issuesWidget}
<form method=post enctype=#{enctype}>
    ^{form}
|]

postRootR :: Handler Html
postRootR :: Handler Markup
postRootR = do
  ((FormResult InputFileForm
res, WidgetFor App ()
form), Enctype
enctype) <- Form InputFileForm
-> HandlerFor
     App ((FormResult InputFileForm, WidgetFor App ()), 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 Form InputFileForm
inputFileForm

  case FormResult InputFileForm
res of
    FormResult InputFileForm
FormMissing     -> WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [Text
"error - missing data"] Enctype
enctype WidgetFor App ()
form
    FormFailure [Text]
x   -> WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [Text]
x Enctype
enctype WidgetFor App ()
form
    FormSuccess InputFileForm
formRes -> do
      ByteString
contents <- FileInfo -> HandlerFor App ByteString
forall (m :: * -> *). MonadResource m => FileInfo -> m ByteString
fileSourceByteString (FileInfo -> HandlerFor App ByteString)
-> FileInfo -> HandlerFor App ByteString
forall a b. (a -> b) -> a -> b
$ InputFileForm -> FileInfo
ifFileInfo InputFileForm
formRes
      let filename :: Text
filename = FileInfo -> Text
fileName (FileInfo -> Text) -> FileInfo -> Text
forall a b. (a -> b) -> a -> b
$ InputFileForm -> FileInfo
ifFileInfo InputFileForm
formRes
      if Text -> Text -> HasLeadingSpace
Text.isSuffixOf Text
"xml" Text
filename then
        case ByteString -> Either SepaParseErrors SepaDirectCoreResults
readSepaDirectCoreScheme ByteString
contents of
          Left SepaParseErrors
err -> WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SepaParseErrors -> String
forall a. Show a => a -> String
show SepaParseErrors
err] Enctype
enctype WidgetFor App ()
form
          Right SepaDirectCoreResults
res' -> InputFileForm -> [ING] -> Handler Markup
renderDownload InputFileForm
formRes (SepaGlobals -> SepaDirectCoreScheme -> ING
sepaDirectCoreSchemeToING (SepaDirectCoreResults -> SepaGlobals
sdcrGlob SepaDirectCoreResults
res') (SepaDirectCoreScheme -> ING) -> [SepaDirectCoreScheme] -> [ING]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SepaDirectCoreResults -> [SepaDirectCoreScheme]
sdcrRows SepaDirectCoreResults
res')
      else case ByteString -> Either String (Vector N26)
readN26BS (ByteString -> Either String (Vector N26))
-> ByteString -> Either String (Vector N26)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
contents of
        Left String
err -> WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Enctype -> WidgetFor App () -> WidgetFor App ()
inputForm [String -> Text
pack String
err] Enctype
enctype WidgetFor App ()
form
        Right Vector N26
n26 -> InputFileForm -> [ING] -> Handler Markup
renderDownload InputFileForm
formRes (Text -> N26 -> ING
n26ToING (InputFileForm -> Text
ifBank InputFileForm
formRes) (N26 -> ING) -> [N26] -> [ING]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector N26 -> [N26]
forall a. Vector a -> [a]
toList Vector N26
n26)

renderDownload :: InputFileForm -> [ING] -> Handler Html
renderDownload :: InputFileForm -> [ING] -> Handler Markup
renderDownload InputFileForm
form [ING]
ings =
          let
            csvOut :: ByteString
csvOut  = ([ING] -> ByteString
writeCsv [ING]
ings)
            contentText :: Text
contentText = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
csvOut
            downloadText :: Text
downloadText = Text
"data:text/plain;base64," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Base64 'StdPadded Text -> Text
forall (k :: Alphabet) a. Base64 k a -> a
extractBase64 (Base64 'StdPadded Text -> Text) -> Base64 'StdPadded Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Base64 'StdPadded Text
encodeBase64 (ByteString -> Base64 'StdPadded Text)
-> ByteString -> Base64 'StdPadded Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
csvOut)
          in
          WidgetFor App () -> Handler Markup
layout (WidgetFor App () -> Handler Markup)
-> WidgetFor App () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
curTime <- IO UTCTime -> WidgetFor App UTCTime
forall a. IO a -> WidgetFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let
                timeStr :: String
                timeStr :: String
timeStr = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F_%H-%M" UTCTime
curTime
                downloadFileName :: String
downloadFileName = String
"snelstart-import-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
timeStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".csv"
            (RY App -> Css) -> WidgetFor App ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ App) =>
(RY App -> Css) -> m ()
toWidget RY App -> Css
[lucius|
                pre {
                  overflow: scroll;
                  width: 100%;
                  position: absolute;
                  left: 0;
                  background-color: lightgray;
                  padding: 1em;
                }
            |]
            WidgetFor App ()
[whamlet|
                <table>
                  <tr>
                    <th>_{MsgBank}
                    <td>#{ifBank form }
                  <tr>
                    <th>_{MsgFilename}
                    <td>#{fileName $ ifFileInfo form }

                <h2>_{MsgContents}
                <a href=#{downloadText} download=#{downloadFileName}>_{MsgDownload}
                <pre>
                  <code>
                    #{contentText}
                |]