1 files changed, 187 insertions, 0 deletions
diff --git a/hs/src/Handlingar/Common.hs b/hs/src/Handlingar/Common.hs
new file mode 100644
index 0000000..dec38c6
--- /dev/null
+++ b/hs/src/Handlingar/Common.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE OverloadedStrings
+           , ImportQualifiedPost
+           #-}
+
+module Handlingar.Common
+( decoder
+, findAlternative
+, formatMail
+, getVimwikiPage
+, handleBilagaHeading
+, handleBlocks
+, handleMailLink
+, replaceLinks
+, rewriteLink
+, shorten
+, uriChars
+) where
+
+import Control.Monad.State.Lazy
+import Data.ByteString (ByteString)
+import Data.Default (def)
+import Data.Map ((!))
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Text (Text, pack, unpack, strip)
+import Data.Text.Encoding (decodeLatin1, decodeUtf8)
+import Data.Text.Encoding.Base64 (encodeBase64)
+import Data.Text.IO qualified as T
+import Mail (getMail, MailPart(..), getBytes, getFile)
+import Network.URI (URI, uriPath)
+import Network.URI.Encode (decode)
+import System.IO (Handle)
+import System.Process (cleanupProcess)
+import Text.Pandoc (readVimwiki, readHtml, PandocMonad, PandocIO, writePlain)
+import Text.Pandoc.Builder
+import Text.Pandoc.Extract (AppendixItem, extractKV)
+import Text.Pandoc.Items (comment, dlist)
+import Text.Pandoc.Walk (walk, walkM)
+import Util (splitBy)
+
+
+handleBilagaHeading :: [Inline] -> Text -> Block
+handleBilagaHeading is ref = Header 1 ("bilaga:" <> ref, [], []) is
+
+-- Takes a list of Pandoc Blocks starting with a heading. If the first
+-- element after the heading is a Definition list, then parse that to
+-- kv-pairs, and return it also.
+handleBlocks :: PandocMonad m => [Block] -> m (Text, [(Text, Text)], [Block])
+handleBlocks (head:DefinitionList definitions:blocks) = do
+    heading <- writePlain def (Pandoc nullMeta [head])
+    kvs <- mapM extractKV definitions
+    return (strip heading, kvs, blocks)
+handleBlocks (head:blocks) = do
+    heading <- writePlain def (Pandoc nullMeta [head])
+    return (strip heading, [], blocks)
+handleBlocks blocks = return ("Heading missing", [], blocks)
+
+
+shorten :: Block -> Block
+shorten (BlockQuote _) = BlockQuote [ Para [ Code ("", [], []) "[...]" ] ]
+shorten x = x
+
+
+rewriteLink :: Inline -> State [AppendixItem] Inline
+rewriteLink (Link _ is (target, "wikilink")) = do
+    let appendixRef = encodeBase64 target
+    let txt = [ Str "(bilaga"
+              , RawInline (Format "latex")
+                          ("~\\ref{bilaga:" <> appendixRef <> "}")
+              , Str ")"
+              ]
+    let lnk = Link ("", [], [ ("reference-type", "ref")
+                            , ("reference", "bilaga:" <> appendixRef) ])
+                   (is <> [Superscript txt])
+                   ( "#bilaga:" <> appendixRef, "" )
+    modify ((is, appendixRef, target):)
+    return lnk
+rewriteLink x = return x
+
+replaceLinks :: Pandoc -> (Pandoc, [AppendixItem])
+replaceLinks = flip runState [] . walkM rewriteLink
+
+
+uriChars :: Set Char
+uriChars = Set.fromList $ ":/?#"  -- Allows us to modifiy existing URL
+                        <> "-._~" -- URL safe
+                        <> ['A'..'Z'] <> ['a'..'z'] <> ['0'..'9']
+
+getVimwikiPage :: FilePath -> PandocIO [Block]
+getVimwikiPage path = do
+    text <- liftIO $ T.readFile path
+    Pandoc _ blocks <- readVimwiki def text
+    return blocks
+
+findAlternative :: [MailPart] -> Maybe MailPart
+findAlternative [] = Nothing
+findAlternative (m@MailPart { contentType = contentType }:xs) = case contentType of
+    "text/html"  -> Just m
+    "text/plain" -> Just m
+    _            -> findAlternative xs
+
+
+-- TODO where are these strings defined
+-- Strict Bytestring
+decoder :: String -> (ByteString -> Text)
+decoder "iso-8859-1" = decodeLatin1
+decoder "utf-8"      = decodeUtf8
+-- decoder _            = decodeUtf8Lenient
+decoder _            = decodeLatin1
+
+
+handleMailBody :: (Handle, Handle) -> MailPart -> PandocIO [Block]
+handleMailBody ports mail =
+    case splitBy '/' $ contentType mail of
+        ("multipart", "alternative") -> do
+            case findAlternative $ reverse $ parts mail of
+                Just part -> handleMailBody ports part
+                Nothing   -> return [ Para [ Str "Couldn't find any suitable alternative" ] ]
+        -- mixed, but any unknown should be treated as mixed
+        ("multipart", _) -> concat <$> mapM (handleMailBody ports) (parts mail)
+        ("text", "plain") -> do
+            bytes <- liftIO $ getBytes (partId mail) ports
+            let content = decoder (fromMaybe "ASCII" $ charset mail) bytes
+            return [ CodeBlock ("", [], []) content ]
+        ("text", "html") -> do
+            bytes <- liftIO $ getBytes (partId mail) ports
+            let content = decoder (fromMaybe "ASCII" $ charset mail) bytes
+            pdoc <- readHtml def content
+            -- TODO renumber links
+            let Pandoc _ blocks = walk shorten pdoc
+            return blocks
+        ("image", _) -> do
+            tmpFile <- liftIO $ getFile (partId mail) ports
+            let img = [ Plain
+                        [ Image ("", [], [])
+                          [Str "Image Caption?"]
+                          (pack tmpFile, "") ]]
+            let figure = [ Figure ("", [], []) -- TODO figure ref
+                      -- (Caption Nothing [Plain [Str . filename mail]])
+                      (Caption Nothing [Plain [Str . pack . show $ filename mail]])
+                      img
+                      ]
+            return img
+        -- TODO
+        -- ("application", "pdf") -> do
+        _  -> return [ Header 2 ("", [], []) [ Str "Attachment omitted" ]
+                     , dlist [ ("Content-Type", contentType mail)
+                             , ("Filename", show . filename $ mail) ]
+                     ]
+
+-- TODO Titlecase the headers
+-- TODO from and to should monospace the
+--      address (but not the name)
+formatMail :: MailPart -> (Handle, Handle) -> PandocIO [Block]
+formatMail mail ports = do
+    let keys = ["from", "to", "subject", "date"]
+    let f key = ( [Str $ key <> ":"]
+                , [[Plain [ Str . pack $ headers mail ! unpack key ]]]
+                )
+    let kvs = map f keys
+
+    body <- handleMailBody ports mail
+
+    return $ DefinitionList kvs : body
+
+
+handleMailLink :: URI -> PandocIO [Block]
+handleMailLink uri = do
+    let id = decode . uriPath $ uri
+    -- liftIO $ print id
+    mail' <- liftIO $ getMail id
+    -- TODO #short
+    body <- case mail' of
+        Left err -> return [ Para [ Str "From "
+                                    , Code ("", [], []) "getMail:"  ]
+                             , Para [Str . pack $ err]
+                             , Para [Code ("", [], []) (pack id) ]]
+        Right (mail, proc@(Just stdin, Just stdout, _, _)) -> do
+            -- TODO "short" `in` uriFrag
+            bs <- formatMail mail (stdout, stdin)
+            liftIO $ cleanupProcess proc
+            return bs
+        -- TODO error
+        _ -> return []
+
+    return $ comment ("msg id: " <> pack id) <> body