{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Codec.Archive.Zip (addEntryToArchive, emptyArchive, fromArchive, toEntry)
import Control.Category ((>>>))
import Control.Monad (forM)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (decode)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.ByteString.Lazy qualified as Lazy
import Data.ByteString.Lazy qualified as ByteString.Lazy
import Data.Fixed (Centi)
import Data.Foldable (fold, toList)
import Data.List qualified as List
import Data.Map.Lazy (Map)
import Data.Map.Lazy qualified as Map
import Data.Monoid.Textual (fromText, toString)
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..))
import Data.String (fromString)
import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Network.HTTP.Types.Status (statusCode, ok200, internalServerError500,
notFound404, unsupportedMediaType415, unprocessableEntity422)
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Network.Wai.Parse (FileInfo (..))
import System.Directory (removeDirectoryRecursive)
import System.FilePath.Posix ((</>))
import System.Log.FastLogger (LogType'(LogFile), FileLogSpec(FileLogSpec), toLogStr, withTimedFastLogger)
import System.Log.FastLogger.Date (newTimeCache, simpleTimeFormat)
import System.Posix.Temp (mkdtemp)
import Text.FDF qualified as FDF (mapWithKey, parse, serialize)
import Text.Read (readMaybe)
import Web.Scotty (file, files, finish, formParamMaybe, get, middleware, pathParam, post, raw,
scotty, setHeader, status, text)
import Paths_canadian_income_tax (getDataDir)
import Tax.Canada (completeRelevantForms)
import Tax.Canada.Federal qualified as Federal
import Tax.Canada.FormKey (FormKey)
import Tax.Canada.FormKey qualified as FormKey
import Tax.PDFtk (fdf2pdf, pdfFile2fdf)
import Prelude hiding (log)
main :: IO ()
main = do
dataDir <- getDataDir
t4fdfBytes <- ByteString.readFile (dataDir </> "fdf" </> "t4-fill-25e.fdf")
let readEmptyForm baseName = (,) completeName <$> ByteString.Lazy.readFile completePath
where completePath = dataDir </> "pdf" </> completeName
completeName = Text.unpack baseName <> "-fill-25e.pdf"
emptyForms <- traverse readEmptyForm Federal.formFileNames
let t4fdf = case FDF.parse t4fdfBytes of
Left err -> error ("Can't load built-in T4 FDF: " <> err)
Right parsed -> parsed
logDestination = LogFile (FileLogSpec "taxell.log" (2^(20::Int)) 16) 1024
timer <- newTimeCache simpleTimeFormat
withTimedFastLogger timer logDestination
$ \l-> let log msg = liftIO $ l (\timestamp-> toLogStr timestamp <> " - " <> msg <> "\n") in (log "Started" >>)
$ scotty 3000 $ do
middleware logStdoutDev
get "/" $ do
setHeader "Content-Type" "text/html; charset=utf-8"
file "web/client/build/index.html"
get "/about.html" $ do
file "web/static/about.html"
get "/shared.css" $ do
file "web/static/shared.css"
post "/save/:province" $ do
provinceCode <- pathParam "province"
t4param <- formParamMaybe "T4"
pdfFiles <- files
log ("Save " <> toLogStr provinceCode <> ": "
<> maybe "no" (const "with") t4param <> " T4s, " <> toLogStr (show (fst <$> pdfFiles)))
now <- liftIO $ round . nominalDiffTimeToSeconds <$> getPOSIXTime
let pdfArchive = foldr addPDF emptyArchive pdfFiles
addPDF (_, FileInfo name _ c) = addEntryToArchive (toEntry (fromUTF8 name) now c)
ByteStringUTF8 province = fromText provinceCode
completeArchive = fromArchive
$ addEntryToArchive (toEntry "province" now $ Lazy.fromStrict province)
$ maybe id (addEntryToArchive . toEntry "T4s" now) t4param
$ pdfArchive
setHeader "Content-Type" "application/zip"
setHeader "Content-Disposition" "attachment; filename=\"taxell-save.zip\"; filename*=\"taxell-save.zip\""
raw completeArchive
post "/t1/PDF/:province" $ do
provinceCode <- pathParam "province"
province <- case readMaybe (Text.Lazy.unpack provinceCode)
of Nothing -> status notFound404
>> text ("No such province as " <> provinceCode)
>> finish
Just p -> pure p
t4param <- formParamMaybe "T4"
let t4m = Map.mapKeysMonotonic (\k-> "Box" <> k <> "[0]") <$> fold (t4param >>= decode) :: [Map Text Centi]
resolveForm (key, FileInfo name _ content)
| Just formKey <- readMaybe (Text.unpack key) = Right (formKey, (fromUTF8 name, content))
| otherwise = Left key
pdfFiles <- (traverse resolveForm <$> files) >>= \case
Left name -> status notFound404
>> text ("No such form key as " <> Text.Lazy.fromStrict name)
>> finish
Right fs -> pure fs
log ("Complete " <> toLogStr provinceCode <> ": "
<> toLogStr (length t4m) <> " T4s, " <> toLogStr (show (fst <$> pdfFiles)))
let allPdfFiles = Map.toList (Map.fromList pdfFiles <> emptyForms)
dir <- liftIO $ mkdtemp "tax"
fdfBytes <- liftIO $ fmap sequenceA $ forM allPdfFiles $ \(key, (name, content))-> do
let path = dir </> name
Lazy.writeFile path content
fdf <- pdfFile2fdf path
pure ((,) key <$> fdf)
case do fdfs <- first ((,) unsupportedMediaType415)
$ fdfBytes >>= traverse (traverse $ Lazy.toStrict >>> FDF.parse)
let (inputFDFs, _ioFDFs) = List.partition ((FormKey.T4 ==) . fst) fdfs
inputT4s = foldMap injectT4 t4m
injectT4 values = [(FormKey.T4, FDF.mapWithKey injectT4box t4fdf)]
where injectT4box keyPath ""
| Just v <- List.find (Text.isPrefixOf "Box") keyPath >>= (`Map.lookup` values)
= Text.pack $ show v
injectT4box _ v = v
inputForms <- first ((,) unprocessableEntity422) $ Federal.loadInputForms $ inputFDFs <> inputT4s
first ((,) unprocessableEntity422) $ completeRelevantForms province inputForms (Map.fromList fdfs)
of Left (code, err) ->
log ("Error " <> toLogStr code.statusCode <> ": " <> toLogStr err)
>> status code >> text (fromString err)
Right fdfs' -> do
log ("Completed " <> toLogStr provinceCode <> ": " <> toLogStr (show (Map.keys fdfs')))
let fdfBytes' = Lazy.fromStrict . FDF.serialize <$> fdfs'
replaceContent :: FormKey -> Lazy.ByteString
-> IO (Either String (FilePath, Lazy.ByteString))
replaceContent key content = case List.lookup key allPdfFiles of
Just (name, _) -> ((,) name <$>) <$> fdf2pdf (dir </> name) content
Nothing -> pure (Left $ "Unknown key " <> show key)
pdfFiles' <- liftIO $ Map.traverseWithKey replaceContent fdfBytes'
case toList <$> sequenceA pdfFiles' of
Left err -> do
log ("Error 500: " <> toLogStr err)
status internalServerError500 >> text (fromString err)
Right [(name, pdf)] -> do
status ok200
setHeader "Content-Type" "application/pdf"
setHeader "Content-Disposition" ("attachment; filename=\"" <> Text.Lazy.pack name
<> "\"; filename*=\"" <> Text.Lazy.pack name <> "\"")
raw pdf
Right pdfFiles'' -> do
now <- liftIO $ round . nominalDiffTimeToSeconds <$> getPOSIXTime
let pdfArchive = foldr addPDF emptyArchive pdfFiles''
addPDF (name, c) = addEntryToArchive (toEntry name now c)
status ok200
setHeader "Content-Type" "application/zip"
raw (fromArchive pdfArchive)
liftIO $ removeDirectoryRecursive dir
middleware $ staticPolicy (noDots >-> addBase "web/client/build")
fromUTF8 :: ByteString -> String
fromUTF8 = toString mempty . ByteStringUTF8