{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module      : Text.Pandoc.Class.PandocPure
Copyright   : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
License     : GNU GPL, version 2 or above

Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
Stability   : alpha
Portability : portable

This module defines a pure instance 'PandocPure' of the @'PandocMonad'@
typeclass. This instance is useful for testing, or when all IO access is
prohibited for security reasons.
-}
module Text.Pandoc.Class.PandocPure
  ( PureState(..)
  , getPureState
  , getsPureState
  , putPureState
  , modifyPureState
  , PandocPure(..)
  , FileTree
  , FileInfo(..)
  , addToFileTree
  , insertInFileTree
  , runPure
  ) where

import Codec.Archive.Zip
import Control.Monad.Trans ( MonadTrans(lift) )
import Control.Monad.Except
    ( ExceptT(..), MonadError(throwError), runExceptT )
import Control.Monad.State.Strict
    ( StateT(StateT),
      State,
      MonadState(put, get),
      modify,
      evalState,
      evalStateT )
import Control.Monad (foldM)
import Data.Default
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
import Data.Time.LocalTime (TimeZone, utc)
import Data.Word (Word8)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>))
import System.FilePath.Glob (match, compile)
import System.Random (StdGen, split, mkStdGen)
import Text.Pandoc.Class.CommonState (CommonState (..))
import Text.Pandoc.Class.PandocMonad
import Text.Pandoc.Error
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Text as T
import qualified System.Directory as Directory (getModificationTime)

-- | The 'PureState' contains ersatz representations
-- of things that would normally be obtained through IO.
data PureState = PureState
  { PureState -> StdGen
stStdGen     :: StdGen
  , PureState -> [Word8]
stWord8Store :: [Word8]    -- ^ should be infinite, i.e. [1..]
  , PureState -> [Int]
stUniqStore  :: [Int]      -- ^ should be infinite and contain every
                               -- element at most once, e.g. [1..]
  , PureState -> [(Text, Text)]
stEnv :: [(Text, Text)]
  , PureState -> UTCTime
stTime :: UTCTime
  , PureState -> TimeZone
stTimeZone :: TimeZone
  , PureState -> Archive
stReferenceDocx :: Archive
  , PureState -> Archive
stReferencePptx :: Archive
  , PureState -> Archive
stReferenceODT :: Archive
  , PureState -> FileTree
stFiles :: FileTree
  , PureState -> ByteString
stStdin :: B.ByteString
  , PureState -> FileTree
stUserDataFiles :: FileTree
  , PureState -> FileTree
stCabalDataFiles :: FileTree
  }

instance Default PureState where
  def :: PureState
def = PureState
        { stStdGen :: StdGen
stStdGen = Int -> StdGen
mkStdGen Int
1848
        , stWord8Store :: [Word8]
stWord8Store = [Word8
1..]
        , stUniqStore :: [Int]
stUniqStore = [Int
1..]
        , stEnv :: [(Text, Text)]
stEnv = [(Text
"USER", Text
"pandoc-user")]
        , stTime :: UTCTime
stTime = POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0
        , stTimeZone :: TimeZone
stTimeZone = TimeZone
utc
        , stReferenceDocx :: Archive
stReferenceDocx = Archive
emptyArchive
        , stReferencePptx :: Archive
stReferencePptx = Archive
emptyArchive
        , stReferenceODT :: Archive
stReferenceODT = Archive
emptyArchive
        , stFiles :: FileTree
stFiles = forall a. Monoid a => a
mempty
        , stStdin :: ByteString
stStdin = forall a. Monoid a => a
mempty
        , stUserDataFiles :: FileTree
stUserDataFiles = forall a. Monoid a => a
mempty
        , stCabalDataFiles :: FileTree
stCabalDataFiles = forall a. Monoid a => a
mempty
        }


-- | Retrieve the underlying state of the @'PandocPure'@ type.
getPureState :: PandocPure PureState
getPureState :: PandocPure PureState
getPureState = forall a.
ExceptT PandocError (StateT CommonState (State PureState)) a
-> PandocPure a
PandocPure forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get

-- | Retrieve a value from the underlying state of the @'PandocPure'@
-- type.
getsPureState :: (PureState -> a) -> PandocPure a
getsPureState :: forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> a
f = PureState -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PandocPure PureState
getPureState

-- | Set a new state for the @'PandocPure'@ type.
putPureState :: PureState -> PandocPure ()
putPureState :: PureState -> PandocPure ()
putPureState PureState
ps= forall a.
ExceptT PandocError (StateT CommonState (State PureState)) a
-> PandocPure a
PandocPure forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put PureState
ps

-- | Modify the underlying state of the @'PandocPure'@ type.
modifyPureState :: (PureState -> PureState) -> PandocPure ()
modifyPureState :: (PureState -> PureState) -> PandocPure ()
modifyPureState PureState -> PureState
f = forall a.
ExceptT PandocError (StateT CommonState (State PureState)) a
-> PandocPure a
PandocPure forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify PureState -> PureState
f

-- | Captures all file-level information necessary for a @'PandocMonad'@
-- conforming mock file system.
data FileInfo = FileInfo
  { FileInfo -> UTCTime
infoFileMTime :: UTCTime
  , FileInfo -> ByteString
infoFileContents :: B.ByteString
  }

-- | Basis of the mock file system used by @'PandocPure'@.
newtype FileTree = FileTree { FileTree -> Map FilePath FileInfo
unFileTree :: M.Map FilePath FileInfo }
  deriving (NonEmpty FileTree -> FileTree
FileTree -> FileTree -> FileTree
forall b. Integral b => b -> FileTree -> FileTree
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> FileTree -> FileTree
$cstimes :: forall b. Integral b => b -> FileTree -> FileTree
sconcat :: NonEmpty FileTree -> FileTree
$csconcat :: NonEmpty FileTree -> FileTree
<> :: FileTree -> FileTree -> FileTree
$c<> :: FileTree -> FileTree -> FileTree
Semigroup, Semigroup FileTree
FileTree
[FileTree] -> FileTree
FileTree -> FileTree -> FileTree
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [FileTree] -> FileTree
$cmconcat :: [FileTree] -> FileTree
mappend :: FileTree -> FileTree -> FileTree
$cmappend :: FileTree -> FileTree -> FileTree
mempty :: FileTree
$cmempty :: FileTree
Monoid)

-- | Retrieve @'FileInfo'@ of the given @'FilePath'@ from a
-- @'FileTree'@.
getFileInfo :: FilePath -> FileTree -> Maybe FileInfo
getFileInfo :: FilePath -> FileTree -> Maybe FileInfo
getFileInfo FilePath
fp FileTree
tree =
  forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FilePath -> FilePath
makeCanonical FilePath
fp) (FileTree -> Map FilePath FileInfo
unFileTree FileTree
tree)

-- | Add the specified file to the FileTree. If file
-- is a directory, add its contents recursively.
addToFileTree :: FileTree -> FilePath -> IO FileTree
addToFileTree :: FileTree -> FilePath -> IO FileTree
addToFileTree FileTree
tree FilePath
fp = do
  Bool
isdir <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp
  if Bool
isdir
     then do -- recursively add contents of directories
       let isSpecial :: a -> Bool
isSpecial a
".." = Bool
True
           isSpecial a
"."  = Bool
True
           isSpecial a
_    = Bool
False
       [FilePath]
fs <- forall a b. (a -> b) -> [a] -> [b]
map (FilePath
fp FilePath -> FilePath -> FilePath
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => a -> Bool
isSpecial) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
fp
       forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FileTree -> FilePath -> IO FileTree
addToFileTree FileTree
tree [FilePath]
fs
     else do
       ByteString
contents <- FilePath -> IO ByteString
B.readFile FilePath
fp
       UTCTime
mtime <- FilePath -> IO UTCTime
Directory.getModificationTime FilePath
fp
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> FileInfo -> FileTree -> FileTree
insertInFileTree FilePath
fp FileInfo{ infoFileMTime :: UTCTime
infoFileMTime = UTCTime
mtime
                                            , infoFileContents :: ByteString
infoFileContents = ByteString
contents } FileTree
tree

-- | Insert an ersatz file into the 'FileTree'.
insertInFileTree :: FilePath -> FileInfo -> FileTree -> FileTree
insertInFileTree :: FilePath -> FileInfo -> FileTree -> FileTree
insertInFileTree FilePath
fp FileInfo
info (FileTree Map FilePath FileInfo
treemap) =
  Map FilePath FileInfo -> FileTree
FileTree forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FilePath -> FilePath
makeCanonical FilePath
fp) FileInfo
info Map FilePath FileInfo
treemap

newtype PandocPure a = PandocPure {
  forall a.
PandocPure a
-> ExceptT PandocError (StateT CommonState (State PureState)) a
unPandocPure :: ExceptT PandocError
                  (StateT CommonState (State PureState)) a
  } deriving ( forall a b. a -> PandocPure b -> PandocPure a
forall a b. (a -> b) -> PandocPure a -> PandocPure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PandocPure b -> PandocPure a
$c<$ :: forall a b. a -> PandocPure b -> PandocPure a
fmap :: forall a b. (a -> b) -> PandocPure a -> PandocPure b
$cfmap :: forall a b. (a -> b) -> PandocPure a -> PandocPure b
Functor
             , Functor PandocPure
forall a. a -> PandocPure a
forall a b. PandocPure a -> PandocPure b -> PandocPure a
forall a b. PandocPure a -> PandocPure b -> PandocPure b
forall a b. PandocPure (a -> b) -> PandocPure a -> PandocPure b
forall a b c.
(a -> b -> c) -> PandocPure a -> PandocPure b -> PandocPure c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. PandocPure a -> PandocPure b -> PandocPure a
$c<* :: forall a b. PandocPure a -> PandocPure b -> PandocPure a
*> :: forall a b. PandocPure a -> PandocPure b -> PandocPure b
$c*> :: forall a b. PandocPure a -> PandocPure b -> PandocPure b
liftA2 :: forall a b c.
(a -> b -> c) -> PandocPure a -> PandocPure b -> PandocPure c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PandocPure a -> PandocPure b -> PandocPure c
<*> :: forall a b. PandocPure (a -> b) -> PandocPure a -> PandocPure b
$c<*> :: forall a b. PandocPure (a -> b) -> PandocPure a -> PandocPure b
pure :: forall a. a -> PandocPure a
$cpure :: forall a. a -> PandocPure a
Applicative
             , Applicative PandocPure
forall a. a -> PandocPure a
forall a b. PandocPure a -> PandocPure b -> PandocPure b
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> PandocPure a
$creturn :: forall a. a -> PandocPure a
>> :: forall a b. PandocPure a -> PandocPure b -> PandocPure b
$c>> :: forall a b. PandocPure a -> PandocPure b -> PandocPure b
>>= :: forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
$c>>= :: forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
Monad
             , MonadError PandocError
             )

-- | Run a 'PandocPure' operation.
runPure :: PandocPure a -> Either PandocError a
runPure :: forall a. PandocPure a -> Either PandocError a
runPure PandocPure a
x = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState forall a. Default a => a
def forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall a. Default a => a
def forall a b. (a -> b) -> a -> b
$
            forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
            forall a.
PandocPure a
-> ExceptT PandocError (StateT CommonState (State PureState)) a
unPandocPure PandocPure a
x

instance PandocMonad PandocPure where
  lookupEnv :: Text -> PandocPure (Maybe Text)
lookupEnv Text
s = do
    [(Text, Text)]
env <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> [(Text, Text)]
stEnv
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
s [(Text, Text)]
env)

  getCurrentTime :: PandocPure UTCTime
getCurrentTime = forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> UTCTime
stTime

  getCurrentTimeZone :: PandocPure TimeZone
getCurrentTimeZone = forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> TimeZone
stTimeZone

  newStdGen :: PandocPure StdGen
newStdGen = do
    StdGen
oldGen <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> StdGen
stStdGen
    let (StdGen
genToStore, StdGen
genToReturn) = forall g. RandomGen g => g -> (g, g)
split StdGen
oldGen
    (PureState -> PureState) -> PandocPure ()
modifyPureState forall a b. (a -> b) -> a -> b
$ \PureState
st -> PureState
st { stStdGen :: StdGen
stStdGen = StdGen
genToStore }
    forall (m :: * -> *) a. Monad m => a -> m a
return StdGen
genToReturn

  newUniqueHash :: PandocPure Int
newUniqueHash = do
    [Int]
uniqs <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> [Int]
stUniqStore
    case [Int]
uniqs of
      Int
u : [Int]
us -> do
        (PureState -> PureState) -> PandocPure ()
modifyPureState forall a b. (a -> b) -> a -> b
$ \PureState
st -> PureState
st { stUniqStore :: [Int]
stUniqStore = [Int]
us }
        forall (m :: * -> *) a. Monad m => a -> m a
return Int
u
      [Int]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocShouldNeverHappenError
                        Text
"uniq store ran out of elements"
  openURL :: Text -> PandocPure (ByteString, Maybe Text)
openURL Text
u = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocResourceNotFound Text
u
  readFileLazy :: FilePath -> PandocPure ByteString
readFileLazy FilePath
fp = do
    FileTree
fps <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> FileTree
stFiles
    case FileInfo -> ByteString
infoFileContents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FileTree -> Maybe FileInfo
getFileInfo FilePath
fp FileTree
fps of
      Just ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
BL.fromStrict ByteString
bs)
      Maybe ByteString
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocResourceNotFound forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
  readFileStrict :: FilePath -> PandocPure ByteString
readFileStrict FilePath
fp = do
    FileTree
fps <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> FileTree
stFiles
    case FileInfo -> ByteString
infoFileContents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FileTree -> Maybe FileInfo
getFileInfo FilePath
fp FileTree
fps of
      Just ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
      Maybe ByteString
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocResourceNotFound forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp

  readStdinStrict :: PandocPure ByteString
readStdinStrict = forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> ByteString
stStdin

  glob :: FilePath -> PandocPure [FilePath]
glob FilePath
s = do
    FileTree Map FilePath FileInfo
ftmap <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> FileTree
stFiles
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match (FilePath -> Pattern
compile FilePath
s)) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map FilePath FileInfo
ftmap

  fileExists :: FilePath -> PandocPure Bool
fileExists FilePath
fp = do
    FileTree
fps <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> FileTree
stFiles
    case FilePath -> FileTree -> Maybe FileInfo
getFileInfo FilePath
fp FileTree
fps of
         Maybe FileInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         Just FileInfo
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  getDataFileName :: FilePath -> PandocPure FilePath
getDataFileName FilePath
fp = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
"data/" forall a. [a] -> [a] -> [a]
++ FilePath
fp

  getModificationTime :: FilePath -> PandocPure UTCTime
getModificationTime FilePath
fp = do
    FileTree
fps <- forall a. (PureState -> a) -> PandocPure a
getsPureState PureState -> FileTree
stFiles
    case FileInfo -> UTCTime
infoFileMTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FileTree -> Maybe FileInfo
getFileInfo FilePath
fp FileTree
fps of
      Just UTCTime
tm -> forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
tm
      Maybe UTCTime
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> IOError -> PandocError
PandocIOError (FilePath -> Text
T.pack FilePath
fp)
                    (FilePath -> IOError
userError FilePath
"Can't get modification time")

  getCommonState :: PandocPure CommonState
getCommonState = forall a.
ExceptT PandocError (StateT CommonState (State PureState)) a
-> PandocPure a
PandocPure forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  putCommonState :: CommonState -> PandocPure ()
putCommonState CommonState
x = forall a.
ExceptT PandocError (StateT CommonState (State PureState)) a
-> PandocPure a
PandocPure forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put CommonState
x

  logOutput :: LogMessage -> PandocPure ()
logOutput LogMessage
_msg = forall (m :: * -> *) a. Monad m => a -> m a
return ()