{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Knit.Effect.PandocMonad
(
Pandoc
, PandocEffects
, PandocEffectsIO
, lookupEnv
, getCurrentTime
, getCurrentTimeZone
, newStdGen
, newUniqueHash
, openURL
, readFileLazy
, readFileStrict
, glob
, fileExists
, getDataFileName
, getModificationTime
, getCommonState
, putCommonState
, getsCommonState
, modifyCommonState
, logOutput
, trace
, interpretInPandocMonad
, interpretInIO
, runIO
, absorbPandocMonad
, PA.PandocError
)
where
import qualified Knit.Effect.Logger as Log
import qualified Paths_knit_haskell as Paths
import qualified Polysemy as P
import Polysemy.Internal ( send )
import Polysemy.Internal.Combinators ( stateful )
import qualified Polysemy.Error as P
import qualified Polysemy.ConstraintAbsorber as P
import qualified Text.Pandoc as PA
import qualified Text.Pandoc.MIME as PA
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Data.ByteString as BS
import Data.ByteString.Lazy as LBS
import Data.ByteString.Base64 ( decodeLenient )
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.Text as T
import Control.Monad ( when )
import Control.Monad.Except ( MonadError(..)
, liftIO
)
import qualified Network.URI as NU
import Network.Socket ( withSocketsDo )
import qualified Network.HTTP.Client as NHC
import qualified Network.HTTP.Client.TLS as NHC
( tlsManagerSettings )
import qualified Network.HTTP.Client.Internal as NHC
( addProxy )
import qualified Network.HTTP.Types.Header as NH
( hContentType )
import qualified System.Environment as IO
( lookupEnv
, getEnv
)
import qualified System.IO.Error as IO
( tryIOError )
import qualified Data.Time as IO
( getCurrentTime )
import Data.Time.Clock ( UTCTime )
import Data.Time.LocalTime ( TimeZone )
import qualified Data.Time.LocalTime as IO
( getCurrentTimeZone )
import System.Random ( StdGen )
import qualified System.Random as IO
( newStdGen )
import Data.Unique ( hashUnique )
import qualified Data.Unique as IO
( newUnique )
import qualified System.FilePath.Glob as IO
( glob )
import qualified System.Directory as IO
( getModificationTime )
import qualified System.Directory as Directory
import qualified Debug.Trace
import qualified Control.Exception as E
data Pandoc m r where
LookupEnv ::String -> Pandoc m (Maybe String)
GetCurrentTime ::Pandoc m UTCTime
GetCurrentTimeZone ::Pandoc m TimeZone
NewStdGen ::Pandoc m StdGen
NewUniqueHash ::Pandoc m Int
OpenURL ::String -> Pandoc m (BS.ByteString, Maybe PA.MimeType)
ReadFileLazy ::FilePath -> Pandoc m LBS.ByteString
ReadFileStrict ::FilePath -> Pandoc m BS.ByteString
Glob ::String -> Pandoc m [FilePath]
FileExists ::FilePath -> Pandoc m Bool
GetDataFileName ::FilePath -> Pandoc m FilePath
GetModificationTime ::FilePath -> Pandoc m UTCTime
GetCommonState ::Pandoc m PA.CommonState
PutCommonState ::PA.CommonState -> Pandoc m ()
GetsCommonState ::(PA.CommonState -> a) -> Pandoc m a
ModifyCommonState ::(PA.CommonState -> PA.CommonState) -> Pandoc m ()
LogOutput ::PA.LogMessage -> Pandoc m ()
Trace ::String -> Pandoc m ()
P.makeSem ''Pandoc
pandocSeverity :: PA.LogMessage -> Log.LogSeverity
pandocSeverity lm = case PA.messageVerbosity lm of
PA.ERROR -> Log.Error
PA.WARNING -> Log.Warning
PA.INFO -> Log.Info
logPandocMessage
:: P.Member (Log.Logger Log.LogEntry) effs => PA.LogMessage -> P.Sem effs ()
logPandocMessage lm = send $ Log.Log $ Log.LogEntry
(pandocSeverity lm)
(T.pack . PA.showLogMessage $ lm)
type PandocEffects effs
= ( P.Member Pandoc effs
, P.Member (P.Error PA.PandocError) effs
, P.Member Log.PrefixLog effs
, P.Member (Log.Logger Log.LogEntry) effs
)
absorbPandocMonad
:: P.Members '[P.Error PA.PandocError, Pandoc] r
=> (PA.PandocMonad (P.Sem r) => P.Sem r a)
-> P.Sem r a
absorbPandocMonad = P.absorbWithSem @PA.PandocMonad @Action
(PandocDict lookupEnv
getCurrentTime
getCurrentTimeZone
newStdGen
newUniqueHash
openURL
readFileLazy
readFileStrict
glob
fileExists
getDataFileName
getModificationTime
getCommonState
putCommonState
getsCommonState
modifyCommonState
logOutput
trace
P.throw
P.catch
)
(P.Sub P.Dict)
newtype Action m s' a = Action
{ action :: m a
} deriving (Functor, Applicative, Monad)
data PandocDict m = PandocDict
{
lookupEnv_ :: String -> m (Maybe String)
, getCurrentTime_ :: m UTCTime
, getCurrentTimeZone_ :: m TimeZone
, newStdGen_ ::m StdGen
, newUniqueHash_ :: m Int
, openURL_ :: String -> m (BS.ByteString, Maybe PA.MimeType)
, readFileLazy_ :: FilePath -> m LBS.ByteString
, readFileStrict_ :: FilePath -> m BS.ByteString
, glob_ :: String -> m [FilePath]
, fileExists_ :: FilePath -> m Bool
, getDataFileName_ :: FilePath -> m FilePath
, getModificationTime_ :: FilePath -> m UTCTime
, getCommonState_ :: m PA.CommonState
, putCommonState_ :: PA.CommonState -> m ()
, getsCommonState_ :: forall a. (PA.CommonState -> a) -> m a
, modifyCommonState_ :: (PA.CommonState -> PA.CommonState) -> m ()
, logOutput_ :: PA.LogMessage -> m ()
, trace_ :: String -> m ()
, throwError_ :: forall a. PA.PandocError -> m a
, catchError_ :: forall a. m a -> (PA.PandocError -> m a) -> m a
}
instance (Monad m
, P.Reifies s' (PandocDict m)) => MonadError PA.PandocError (Action m s') where
throwError e = Action $ throwError_ (P.reflect $ P.Proxy @s') e
catchError x f =
Action $ catchError_ (P.reflect $ P.Proxy @s') (action x) (action . f)
instance (Monad m
, MonadError PA.PandocError (Action m s')
, P.Reifies s' (PandocDict m)) => PA.PandocMonad (Action m s') where
lookupEnv = Action . lookupEnv_ (P.reflect $ P.Proxy @s')
getCurrentTime = Action $ getCurrentTime_ (P.reflect $ P.Proxy @s')
getCurrentTimeZone = Action $ getCurrentTimeZone_ (P.reflect $ P.Proxy @s')
newStdGen = Action $ newStdGen_ (P.reflect $ P.Proxy @s')
newUniqueHash = Action $ newUniqueHash_ (P.reflect $ P.Proxy @s')
openURL = Action . openURL_ (P.reflect $ P.Proxy @s')
readFileLazy = Action . readFileLazy_ (P.reflect $ P.Proxy @s')
readFileStrict = Action . readFileStrict_ (P.reflect $ P.Proxy @s')
glob = Action . glob_ (P.reflect $ P.Proxy @s')
fileExists = Action . fileExists_ (P.reflect $ P.Proxy @s')
getDataFileName = Action . getDataFileName_ (P.reflect $ P.Proxy @s')
getModificationTime = Action . getModificationTime_ (P.reflect $ P.Proxy @s')
getCommonState = Action $ getCommonState_ (P.reflect $ P.Proxy @s')
putCommonState = Action . putCommonState_ (P.reflect $ P.Proxy @s')
getsCommonState = Action . getsCommonState_ (P.reflect $ P.Proxy @s')
modifyCommonState = Action . modifyCommonState_ (P.reflect $ P.Proxy @s')
logOutput = Action . logOutput_ (P.reflect $ P.Proxy @s')
trace = Action . trace_ (P.reflect $ P.Proxy @s')
type PandocEffectsIO effs = (PandocEffects effs, P.Member (P.Lift IO) effs)
interpretInIO
:: forall effs a
. ( P.Member (Log.Logger Log.LogEntry) effs
, P.Member (P.Lift IO) effs
, P.Member (P.Error PA.PandocError) effs
)
=> P.Sem (Pandoc ': effs) a
-> P.Sem effs a
interpretInIO = fmap snd . stateful f PA.def
where
liftPair :: forall f x y . Functor f => (x, f y) -> f (x, y)
liftPair (x, fy) = fmap (x, ) fy
f :: Pandoc m x -> PA.CommonState -> P.Sem effs (PA.CommonState, x)
f (LookupEnv s) cs = liftPair (cs, liftIO $ IO.lookupEnv s)
f GetCurrentTime cs = liftPair (cs, liftIO $ IO.getCurrentTime)
f GetCurrentTimeZone cs = liftPair (cs, liftIO IO.getCurrentTimeZone)
f NewStdGen cs = liftPair (cs, liftIO IO.newStdGen)
f NewUniqueHash cs = liftPair (cs, hashUnique <$> liftIO IO.newUnique)
f (OpenURL url) cs = openURLWithState cs url
f (ReadFileLazy fp ) cs = liftPair (cs, liftIOError LBS.readFile fp)
f (ReadFileStrict fp ) cs = liftPair (cs, liftIOError BS.readFile fp)
f (Glob s ) cs = liftPair (cs, liftIOError IO.glob s)
f (FileExists fp) cs = liftPair (cs, liftIOError Directory.doesFileExist fp)
f (GetDataFileName s ) cs = liftPair (cs, liftIOError getDataFileName' s)
f (GetModificationTime fp) cs =
liftPair (cs, liftIOError IO.getModificationTime fp)
f GetCommonState cs = return (cs, cs)
f (GetsCommonState g ) cs = return (cs, g cs)
f (ModifyCommonState g ) cs = return (g cs, ())
f (PutCommonState cs') _ = return (cs', ())
f (LogOutput msg) cs = liftPair (cs, logPandocMessage msg)
f (Trace msg) cs = liftPair
( cs
, when (PA.stTrace cs) $ Debug.Trace.trace ("[trace]" ++ msg) (return ())
)
interpretInPandocMonad
:: forall m effs a
. ( PA.PandocMonad m
, P.Member (P.Lift m) effs
, P.Member (Log.Logger Log.LogEntry) effs
)
=> P.Sem (Pandoc ': effs) a
-> P.Sem effs a
interpretInPandocMonad = P.interpret
(\case
LookupEnv s -> P.sendM @m $ PA.lookupEnv s
GetCurrentTime -> P.sendM @m $ PA.getCurrentTime
GetCurrentTimeZone -> P.sendM @m $ PA.getCurrentTimeZone
NewStdGen -> P.sendM @m $ PA.newStdGen
NewUniqueHash -> P.sendM @m $ PA.newUniqueHash
OpenURL s -> P.sendM @m $ PA.openURL s
ReadFileLazy fp -> P.sendM @m $ PA.readFileLazy fp
ReadFileStrict fp -> P.sendM @m $ PA.readFileStrict fp
Glob fp -> P.sendM @m $ PA.glob fp
FileExists fp -> P.sendM @m $ PA.fileExists fp
GetDataFileName fp -> P.sendM @m $ PA.getDataFileName fp
GetModificationTime fp -> P.sendM @m $ PA.getModificationTime fp
GetCommonState -> P.sendM @m $ PA.getCommonState
PutCommonState cs -> P.sendM @m $ PA.putCommonState cs
GetsCommonState f -> P.sendM @m $ PA.getsCommonState f
ModifyCommonState f -> P.sendM @m $ PA.modifyCommonState f
LogOutput msg -> logPandocMessage msg
Trace s -> P.sendM @m $ PA.trace s
)
runIO
:: [Log.LogSeverity]
-> P.Sem
'[Pandoc, Log.Logger Log.LogEntry, Log.PrefixLog, P.Error
PA.PandocError, P.Lift IO]
a
-> IO (Either PA.PandocError a)
runIO lss =
P.runM . P.runError . Log.filteredLogEntriesToIO lss . interpretInIO
openURLWithState
:: forall effs
. ( P.Member (Log.Logger Log.LogEntry) effs
, P.Member (P.Lift IO) effs
, P.Member (P.Error PA.PandocError) effs
)
=> PA.CommonState
-> String
-> P.Sem effs (PA.CommonState, (BS.ByteString, Maybe PA.MimeType))
openURLWithState cs u
| Just u'' <- L.stripPrefix "data:" u = do
let mime = L.takeWhile (/= ',') u''
let contents = UTF8.fromString $ NU.unEscapeString $ L.drop 1 $ L.dropWhile
(/= ',')
u''
return (cs, (decodeLenient contents, Just mime))
| otherwise = do
let toReqHeader (n, v) = (CI.mk (UTF8.fromString n), UTF8.fromString v)
customHeaders = fmap toReqHeader $ PA.stRequestHeaders cs
cs' <- report cs $ PA.Fetching u
res <- liftIO $ E.try $ withSocketsDo $ do
let parseReq = NHC.parseRequest
proxy <- IO.tryIOError (IO.getEnv "http_proxy")
let addProxy' x = case proxy of
Left _ -> return x
Right pr -> parseReq pr
>>= \r -> return (NHC.addProxy (NHC.host r) (NHC.port r) x)
req <- parseReq u >>= addProxy'
let req' = req
{ NHC.requestHeaders = customHeaders ++ NHC.requestHeaders req
}
resp <- NHC.newManager NHC.tlsManagerSettings >>= NHC.httpLbs req'
return
( BS.concat $ LBS.toChunks $ NHC.responseBody resp
, UTF8.toString `fmap` lookup NH.hContentType (NHC.responseHeaders resp)
)
case res of
Right r -> return (cs', r)
Left e -> P.throw $ PA.PandocHttpError u e
report
:: (P.Member (Log.Logger Log.LogEntry) effs)
=> PA.CommonState
-> PA.LogMessage
-> P.Sem effs PA.CommonState
report cs msg = do
let verbosity = PA.stVerbosity cs
level = PA.messageVerbosity msg
when (level <= verbosity) $ logPandocMessage msg
let stLog' = msg : (PA.stLog cs)
cs' = cs { PA.stLog = stLog' }
return cs'
liftIOError
:: (P.Member (P.Error PA.PandocError) effs, P.Member (P.Lift IO) effs)
=> (String -> IO a)
-> String
-> P.Sem effs a
liftIOError f u = do
res <- liftIO $ IO.tryIOError $ f u
case res of
Left e -> P.throw $ PA.PandocIOError u e
Right r -> return r
datadir :: IO FilePath
datadir = Paths.getDataDir
getDataFileName' :: FilePath -> IO FilePath
getDataFileName' fp = do
dir <- E.catch @E.IOException (IO.getEnv "pandoc_datadir") (\_ -> datadir)
return (dir ++ "/pandoc-data/" ++ fp)