path: root/hs/src/Handlingar/Common.hs

{-# LANGUAGE OverloadedStrings
           , ImportQualifiedPost
           #-}

module Handlingar.Common
( buildPrimary
, decoder
, findAlternative
, formatMail
, getVimwikiPage
, handleBilaga
, handleBilagaHeading
, handleBlocks
, handleMailLink
, replaceLinks
, shorten
, uriChars
, HandlingarOps(..)
) 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.IO qualified as T
import Mail (getMail, MailPart(..), getBytes, getFile)
import Network.URI (URI, uriPath)
import Network.URI.Encode (decode)
import System.FilePath (takeExtension, (<.>))
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, getHeadingData)
import Text.Pandoc.Items (comment, dlist)
import Text.Pandoc.Walk (walk, walkM)
import Util (splitBy, (<&>))
import Network.URI (parseURI, uriScheme)
import Network.URI.Encode (encodeWith)
import Text.URI.Decode (urlDecode)


data HandlingarOps = HandlingarOps
    -- For any file included from the base document as an appendix,
    -- which originally had a "file:" or "local:" scheme, generate
    -- appropriate resources for that element, and return what should
    -- be included in the appendix section.
    --
    { handleFile :: FilePath -- ^ Path to include, may be relative the current working directory.
                 -> String   -- ^ File extension of the given path, with a leading period
                 -> PandocIO (Maybe [Block])
    -- |
    , rewriteLink :: Inline -> State [AppendixItem] Inline
    , destination :: FilePath
    }

-- See also: Html rebuildLinks
handleBilaga :: HandlingarOps -> [Block] -> Text -> PandocIO (Maybe [Block])
handleBilaga ops currentPage url = case parseURI . encodeWith (`elem` uriChars) . unpack $ url of
    Just uri -> case uriScheme uri of
                    -- A link to another wiki.
                    -- Currently implemented by simply mentioning
                    -- where to look
                    ('w':'n':'.':wikiname) -> return . Just $ [Para [Str $ "Interwiki" <> pack wikiname]]
                    -- File, may (and hopefully is) within wiki the source tree
                    -- Note that both "file:" and "local:" gets turned
                    -- into "file:" by the pandoc parser.
                    "file:" -> do
                        let (Just fname) = urlDecode $ uriPath uri
                        (handleFile ops) fname $ takeExtension fname
                    -- An included email.
                    "mail:" -> Just <$> handleMailLink uri
                    _ -> return $ Just [Para [Str . pack . show $ uri]]
    -- This is an internal wiki link
    Nothing  -> case break (== '#') (unpack url) of
        ("", '#':frag)   -> return $ getHeadingData (pack frag) currentPage
        (page, '#':frag) -> getVimwikiPage (page <.> "wiki") <&> getHeadingData (pack frag)
        (page, "")       -> Just <$> getVimwikiPage (page <.> "wiki")
        _                -> return $ Just [Para [Str "ERROR"]]



-- | Generate a header tag from an appendix reference
handleBilagaHeading :: [Inline] -> Text -> Block
handleBilagaHeading is ref = Header 1 ("bilaga:" <> ref, [], []) is

-- | Extract header, metadata, and contents from a list of Pandoc Blocks.
-- Returns a three-tuple consisting of 
-- * the sections title,
-- * metadata from the section
-- * Further contents of the section
--
-- The title is gotten by rendering the first block in the list into a
-- plain string.
--
-- If the second argument is a definition list, then each of those
-- items will be extracted into a list of key, value pairs
-- 
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




-- | Replace all links in document from source to destination form.
-- The source links are either regular absolute links, or relative
-- links to other items within the source tree. This function
-- translates one such link to a link which is on a suitable form form
-- the output.
-- * For TeX this will probably be a '\ref' element
-- * For HTML a link to another page.
--
-- Note that something which actually creates the output referenced
-- items is also needed.
replaceLinks :: (Inline -> State [AppendixItem] Inline) 
             -> Pandoc -> (Pandoc, [AppendixItem])
replaceLinks rewriteLink = 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


buildPrimary :: PandocMonad m
             => HandlingarOps
             -> Pandoc
             -> m (Pandoc, [AppendixItem])
buildPrimary ops (Pandoc meta blocks) = do
    -- Pandoc meta blocks <- reader def text
    -- let Just blocks = getHeadingData heading blocks
    (heading, kvs, wantedBlocks') <- handleBlocks blocks
    let (pandoc, appendices) = replaceLinks (rewriteLink ops) $ Pandoc meta wantedBlocks'

    let pandoc' = foldl (flip . uncurry $ setMeta) pandoc
                $ ("title", heading) : kvs
    return (pandoc', appendices)