Release code as open sourceHEADmaster

6 files changed, 313 insertions, 0 deletions

diff --git a/scaffolder/src/Text/Edifact/Fetcher/Commons.hs b/scaffolder/src/Text/Edifact/Fetcher/Commons.hs
new file mode 100644
index 0000000..1a6a058
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Commons.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Commons where
+
+import           Text.Edifact.Fetcher.Configuration
+import           Text.Edifact.Scaffolder.Commons
+
+import           Control.Monad                      ((>=>))
+import           Control.Monad.Error.Class          (MonadError, catchError)
+import           Control.Monad.IO.Class             (MonadIO)
+import           Control.Monad.Reader               (ReaderT, runReaderT)
+import           Control.Monad.Trans.Class          (lift)
+import           Data.ByteString                    (ByteString)
+import           Data.Char                          (toLower)
+import           Data.Text                          as T (unpack, pack)
+import           Data.Text.IO                       as TIO (readFile, writeFile)
+import           Formatting
+import           System.Directory                   (doesFileExist)
+import           Text.Pandoc                        as Pandoc hiding (Format,
+                                                               getOutputFile)
+import           Text.Parsec                        (Parsec, runParser)
+
+type Fetcher = ReaderT FetchingEnv PandocIO
+
+runFetcher :: Fetcher () -> FetchingEnv -> IO ()
+runFetcher f = Pandoc.runIOorExplode . runReaderT f
+
+getOutputFile :: Format String (a -> String) -> FilePath -> a -> Fetcher FilePath
+getOutputFile f d c = do
+  home <- getSpecificationHome
+  pure (formatToString (string % "/" % string % "/" % f) home d c)
+
+getUrl :: Format String (a -> String) -> a -> Fetcher String
+getUrl f c = do
+  rev <- getTargetRevision
+  pure (formatToString ("https://service.unece.org/trade/untdid/" % fRevisionLower % f) rev c)
+
+getSpecificationHome :: Fetcher FilePath
+getSpecificationHome = do
+  home <- getHome
+  rev <- getTargetRevision
+  pure (home </> formatToString fRevision rev)
+
+htmlToFile :: String -> (ByteString -> Text) -> FilePath -> Fetcher ()
+htmlToFile url decoder outputFile = () <$ tryCacheOrHtml decoder url outputFile
+
+htmlToFileWithParser :: (Monoid a, Monoid u) => String -> (ByteString -> Text) -> FilePath -> Parsec String u a -> Fetcher a
+htmlToFileWithParser url decoder outputFile parser = do
+  specification <- tryCacheOrHtml decoder url outputFile
+  either (error . show) pure
+    (runParser parser mempty "" (T.unpack specification))
+
+tryCacheOrHtml :: (ByteString -> Text) -> String -> FilePath -> Fetcher Text
+tryCacheOrHtml decoder url path = do
+  fileExists' <- liftIO $ doesFileExist path
+  content <- if fileExists'
+             then liftIO $ TIO.readFile path
+             else readHtmlFromURL decoder url >>= writePlain def
+  content <$ liftIO (TIO.writeFile path content)
+
+readHtmlFromURL :: (ByteString -> Text) -> String -> Fetcher Pandoc
+readHtmlFromURL decoder = lift . (openURL >=> readHtml def . decoder . fst) . pack
+
+lower :: Format r (String -> r)
+lower = mapf (fmap toLower) string
+
+fRevision :: Format r (Revision -> r)
+fRevision = mapf getRevision string
+
+fRevisionLower :: Format r (Revision -> r)
+fRevisionLower = mapf getRevision lower
+
+fMessageCodeLower :: Format r (MessageCode -> r)
+fMessageCodeLower = mapf getMessageCode lower
+
+fSegmentCodeLower :: Format r (SegmentCode -> r)
+fSegmentCodeLower = mapf getSegmentCode lower
+
+fCompositeCodeLower :: Format r (CompositeCode -> r)
+fCompositeCodeLower = mapf getCompositeCode lower
+
+fSimpleCodeLower :: Format r (SimpleCode -> r)
+fSimpleCodeLower = mapf getSimpleCode lower
+
+retry :: (MonadIO m, MonadError b m) => Int -> m a -> m a
+retry n f | n > 1     = f `catchError` const (say "Retrying" >> retry (n-1) f)
+          | otherwise = f
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Composites.hs b/scaffolder/src/Text/Edifact/Fetcher/Composites.hs
new file mode 100644
index 0000000..8f94cc9
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Composites.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Composites
+  ( fetchComposites
+  , compositesDirectory
+  ) where
+
+import           Text.Edifact.Fetcher.Commons
+import           Text.Edifact.Scaffolder.Commons
+
+import           Text.Edifact.Scaffolder.Composites.Specification (listSimples)
+
+import           Data.List                                        as L (nub,
+                                                                        sort)
+import           Data.Text.Encoding                               as TE (decodeUtf8)
+import           Formatting
+
+compositesDirectory :: FilePath
+compositesDirectory = "composites"
+
+fetchComposites :: ([CompositeCode], [SimpleCode]) -> Fetcher [SimpleCode]
+fetchComposites (composites, segments) =
+  let compactSimpleCodes = L.nub . L.sort . mappend segments . concat
+  in compactSimpleCodes <$> traverse (retry 3 . fetchComposite) composites
+
+fetchComposite :: CompositeCode -> Fetcher [SimpleCode]
+fetchComposite code = do
+  say ("Fetching composite " % fCompositeCode) code
+  url <- getUrl ("/trcd/trcd" % fCompositeCodeLower % ".htm") code
+  outputFile <- getOutputFile (fCompositeCodeLower % ".txt") compositesDirectory code
+  htmlToFileWithParser url TE.decodeUtf8 outputFile (snd <$> listSimples)
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs b/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs
new file mode 100644
index 0000000..a074641
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Configuration
+  ( -- * Fetching environment
+    FetchingEnv(..)
+    -- * Parsing helpers
+  , readSelectMessages
+    -- * Shortcuts for reading the environment
+  , getTargetRevision
+  , getHome
+  , getSelectedMessages
+  ) where
+
+import           Text.Edifact.Scaffolder.Commons (MessageCode, Revision,
+                                                  messageCodeParser)
+
+import           Control.Monad.Reader.Class      (MonadReader, asks)
+import           Data.List.NonEmpty              (NonEmpty, nonEmpty)
+import           Text.Parsec                     (char, parse, sepBy1)
+
+data FetchingEnv = FetchingEnv { fetchingRevision  :: Revision
+                               , specificationHome :: FilePath
+                               , selectedMessages  :: Maybe (NonEmpty MessageCode)
+                               }
+
+getTargetRevision :: MonadReader FetchingEnv m => m Revision
+getTargetRevision = asks fetchingRevision
+
+getHome :: MonadReader FetchingEnv m => m FilePath
+getHome = asks specificationHome
+
+getSelectedMessages :: MonadReader FetchingEnv m => m (Maybe (NonEmpty MessageCode))
+getSelectedMessages = asks selectedMessages
+
+readSelectMessages :: Maybe String -> Maybe (NonEmpty MessageCode)
+readSelectMessages value =
+  let tryParse p s = toMaybe . parse p s
+      toMaybe (Right v) = Just v
+      toMaybe _         = Nothing
+      messageCodesParser = messageCodeParser `sepBy1` comma
+      comma = char ','
+  in value >>= tryParse messageCodesParser "" >>= nonEmpty
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Messages.hs b/scaffolder/src/Text/Edifact/Fetcher/Messages.hs
new file mode 100644
index 0000000..9daf98a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Messages.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Messages
+  ( fetchMessages
+  , messagesDirectory
+  ) where
+
+import           Text.Edifact.Fetcher.Commons
+import           Text.Edifact.Fetcher.Configuration
+import           Text.Edifact.Scaffolder.Commons
+
+import           Text.Edifact.Scaffolder.Messages.Specification (listSegments)
+
+import           Data.Foldable                                  (toList)
+import           Data.List                                      as L (nub, sort)
+import           Data.Maybe                                     (mapMaybe)
+import           Data.Text                                      as T (map)
+import           Data.Text.Encoding                             as TE (decodeLatin1,
+                                                                       decodeUtf8)
+import           Formatting
+import           Text.Pandoc                                    as Pandoc hiding (Format,
+                                                                           getOutputFile)
+import           Text.Pandoc.Walk                               (query)
+import           Text.Parsec                                    (parse)
+
+messagesDirectory :: FilePath
+messagesDirectory = "messages"
+
+parseMessageCode :: Text -> Maybe MessageCode
+parseMessageCode =
+  let toMaybe (Right v) = Just v
+      toMaybe _         = Nothing
+  in toMaybe . parse messageCodeParser ""
+
+scanInlineForMessageCode :: Inline -> Maybe MessageCode
+scanInlineForMessageCode (Str label) = parseMessageCode label
+scanInlineForMessageCode _           = Nothing
+
+-- The trick here is to reverse the usage of UNH which is mandatory on every single message
+listAllMessages :: Fetcher [MessageCode]
+listAllMessages =
+  let filterLink (Link _ inlines _) = mapMaybe scanInlineForMessageCode inlines
+      filterLink _                  = []
+      extractMessageCodes = query filterLink
+      loadUNHUsages = readHtmlFromURL TE.decodeUtf8 =<< getUrl ("/trsd/cseg" % fSegmentCodeLower % ".htm") "UNH"
+  in extractMessageCodes <$> loadUNHUsages
+
+listMessages :: Fetcher [MessageCode]
+listMessages = getSelectedMessages >>= maybe listAllMessages (pure . toList)
+
+fetchMessages :: Fetcher [SegmentCode]
+fetchMessages = listMessages >>= fmap (L.nub . L.sort . concat) . traverse fetchMessage
+
+fetchMessage :: MessageCode -> Fetcher [SegmentCode]
+fetchMessage code = do
+  retry 3 (fetchMessageDefinition code)
+  retry 3 (fetchMessageSummary code)
+
+fetchMessageDefinition :: MessageCode -> Fetcher ()
+fetchMessageDefinition code = do
+  say ("Fetching message " % fMessageCode % " definition") code
+  url <- getUrl ("/trmd/" % fMessageCodeLower % "_d.htm") code
+  outputFile <- getOutputFile (fMessageCodeLower % "_d.txt") messagesDirectory code
+  htmlToFile url TE.decodeUtf8 outputFile
+
+fetchMessageSummary :: MessageCode -> Fetcher [SegmentCode]
+fetchMessageSummary code = do
+  say ("Fetching message " % fMessageCode % " summary") code
+  url <- getUrl ("/trmd/" % fMessageCodeLower % "_s.htm") code
+  outputFile <- getOutputFile (fMessageCodeLower % "_s.txt") messagesDirectory code
+  let decoder = cleanupAsciiArt . TE.decodeLatin1
+  htmlToFileWithParser url decoder outputFile listSegments
+
+-- This might not be the proper way to do it...
+-- Use Data.Text.Encoding.decodeUtf8With instead?
+cleanupAsciiArt :: Text -> Text
+cleanupAsciiArt =
+  let f 'Ä' = '-'
+      f '¿' = '+'
+      f '³' = '|'
+      f 'Ù' = '+'
+      f 'Á' = '+'
+      f c   = c
+  in T.map f
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Segments.hs b/scaffolder/src/Text/Edifact/Fetcher/Segments.hs
new file mode 100644
index 0000000..dda1d88
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Segments.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Segments
+  ( fetchSegments
+  , segmentsDirectory
+  ) where
+
+import           Text.Edifact.Fetcher.Commons
+import           Text.Edifact.Scaffolder.Commons
+
+import           Text.Edifact.Scaffolder.Segments.Specification (listCompositesAndSimples)
+import           Text.Edifact.Scaffolder.Segments.Types         (Element,
+                                                                 getComposite,
+                                                                 getSimple)
+
+import           Data.Bifunctor                                 (bimap)
+import           Data.List                                      as L (nub,
+                                                                      partition,
+                                                                      sort)
+import           Data.Maybe                                     (isJust,
+                                                                 mapMaybe)
+import           Data.Text.Encoding                             as TE (decodeUtf8)
+import           Formatting
+
+segmentsDirectory :: FilePath
+segmentsDirectory = "segments"
+
+fetchSegments :: [SegmentCode] -> Fetcher ([CompositeCode], [SimpleCode])
+fetchSegments = fmap (partitionElements . L.nub . L.sort . concat) . traverse (retry 3 . fetchSegment)
+
+partitionElements :: [Element] -> ([CompositeCode], [SimpleCode])
+partitionElements =
+  let isComposite = isJust . getComposite
+  in bimap (mapMaybe getComposite) (mapMaybe getSimple) . partition isComposite
+
+fetchSegment :: SegmentCode -> Fetcher [Element]
+fetchSegment code = do
+  say ("Fetching segment " % fSegmentCode) code
+  url <- getUrl ("/trsd/trsd" % fSegmentCodeLower % ".htm") code
+  outputFile <- getOutputFile (fSegmentCodeLower % ".txt") segmentsDirectory code
+  htmlToFileWithParser url TE.decodeUtf8 outputFile (snd <$> listCompositesAndSimples)
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Simples.hs b/scaffolder/src/Text/Edifact/Fetcher/Simples.hs
new file mode 100644
index 0000000..47951ad
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Simples.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Fetcher.Simples
+  ( fetchSimples
+  , simplesDirectory
+  ) where
+
+import           Text.Edifact.Fetcher.Commons
+import           Text.Edifact.Scaffolder.Commons
+
+
+import           Data.Foldable                   (traverse_)
+import           Data.Text.Encoding              as TE (decodeUtf8)
+import           Formatting
+
+simplesDirectory :: FilePath
+simplesDirectory = "simples"
+
+fetchSimples :: [SimpleCode] -> Fetcher ()
+fetchSimples = traverse_ (retry 3 . fetchSimple)
+
+fetchSimple :: SimpleCode -> Fetcher ()
+fetchSimple code = do
+  say ("Fetching simple " % fSimpleCode) code
+  url <- getUrl ("/uncl/uncl" % fSimpleCodeLower % ".htm") code
+  outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory code
+  htmlToFile url TE.decodeUtf8 outputFile