scaffolder/src/Text/Edifact/Fetcher/Commons.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Text.Edifact.Fetcher.Commons where
   4
   5 import           Text.Edifact.Fetcher.Configuration
   6 import           Text.Edifact.Scaffolder.Commons
   7
   8 import           Control.Monad                      ((>=>))
   9 import           Control.Monad.Error.Class          (MonadError, catchError)
  10 import           Control.Monad.IO.Class             (MonadIO)
  11 import           Control.Monad.Reader               (ReaderT, runReaderT)
  12 import           Control.Monad.Trans.Class          (lift)
  13 import           Data.ByteString                    (ByteString)
  14 import           Data.Char                          (toLower)
  15 import           Data.Text                          as T (unpack, pack)
  16 import           Data.Text.IO                       as TIO (readFile, writeFile)
  17 import           Formatting
  18 import           System.Directory                   (doesFileExist)
  19 import           Text.Pandoc                        as Pandoc hiding (Format,
  20                                                                getOutputFile)
  21 import           Text.Parsec                        (Parsec, runParser)
  22
  23 type Fetcher = ReaderT FetchingEnv PandocIO
  24
  25 runFetcher :: Fetcher () -> FetchingEnv -> IO ()
  26 runFetcher f = Pandoc.runIOorExplode . runReaderT f
  27
  28 getOutputFile :: Format String (a -> String) -> FilePath -> a -> Fetcher FilePath
  29 getOutputFile f d c = do
  30   home <- getSpecificationHome
  31   pure (formatToString (string % "/" % string % "/" % f) home d c)
  32
  33 getUrl :: Format String (a -> String) -> a -> Fetcher String
  34 getUrl f c = do
  35   rev <- getTargetRevision
  36   pure (formatToString ("https://service.unece.org/trade/untdid/" % fRevisionLower % f) rev c)
  37
  38 getSpecificationHome :: Fetcher FilePath
  39 getSpecificationHome = do
  40   home <- getHome
  41   rev <- getTargetRevision
  42   pure (home </> formatToString fRevision rev)
  43
  44 htmlToFile :: String -> (ByteString -> Text) -> FilePath -> Fetcher ()
  45 htmlToFile url decoder outputFile = () <$ tryCacheOrHtml decoder url outputFile
  46
  47 htmlToFileWithParser :: (Monoid a, Monoid u) => String -> (ByteString -> Text) -> FilePath -> Parsec String u a -> Fetcher a
  48 htmlToFileWithParser url decoder outputFile parser = do
  49   specification <- tryCacheOrHtml decoder url outputFile
  50   either (error . show) pure
  51     (runParser parser mempty "" (T.unpack specification))
  52
  53 tryCacheOrHtml :: (ByteString -> Text) -> String -> FilePath -> Fetcher Text
  54 tryCacheOrHtml decoder url path = do
  55   fileExists' <- liftIO $ doesFileExist path
  56   content <- if fileExists'
  57              then liftIO $ TIO.readFile path
  58              else readHtmlFromURL decoder url >>= writePlain def
  59   content <$ liftIO (TIO.writeFile path content)
  60
  61 readHtmlFromURL :: (ByteString -> Text) -> String -> Fetcher Pandoc
  62 readHtmlFromURL decoder = lift . (openURL >=> readHtml def . decoder . fst) . pack
  63
  64 lower :: Format r (String -> r)
  65 lower = mapf (fmap toLower) string
  66
  67 fRevision :: Format r (Revision -> r)
  68 fRevision = mapf getRevision string
  69
  70 fRevisionLower :: Format r (Revision -> r)
  71 fRevisionLower = mapf getRevision lower
  72
  73 fMessageCodeLower :: Format r (MessageCode -> r)
  74 fMessageCodeLower = mapf getMessageCode lower
  75
  76 fSegmentCodeLower :: Format r (SegmentCode -> r)
  77 fSegmentCodeLower = mapf getSegmentCode lower
  78
  79 fCompositeCodeLower :: Format r (CompositeCode -> r)
  80 fCompositeCodeLower = mapf getCompositeCode lower
  81
  82 fSimpleCodeLower :: Format r (SimpleCode -> r)
  83 fSimpleCodeLower = mapf getSimpleCode lower
  84
  85 retry :: (MonadIO m, MonadError b m) => Int -> m a -> m a
  86 retry n f | n > 1     = f `catchError` const (say "Retrying" >> retry (n-1) f)
  87           | otherwise = f