PandocPure.hs

{-# LANGUAGE CPP #-}
{-# 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, 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)

#if MIN_VERSION_random(1,3,0)
import System.Random (splitGen, SplitGen)

split :: SplitGen g => g -> (g, g)
split = splitGen
#else
import System.Random (split)
#endif

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

instance Default PureState where
  def = PureState
        { stStdGen = mkStdGen 1848
        , stWord8Store = [1..]
        , stUniqStore = [1..]
        , stEnv = [("USER", "pandoc-user")]
        , stTime = posixSecondsToUTCTime 0
        , stTimeZone = utc
        , stReferenceDocx = emptyArchive
        , stReferencePptx = emptyArchive
        , stReferenceODT = emptyArchive
        , stFiles = mempty
        , stStdin = mempty
        , stUserDataFiles = mempty
        , stCabalDataFiles = mempty
        }


-- | Retrieve the underlying state of the @'PandocPure'@ type.
getPureState :: PandocPure PureState
getPureState = PandocPure $ lift $ lift get

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

-- | Set a new state for the @'PandocPure'@ type.
putPureState :: PureState -> PandocPure ()
putPureState ps= PandocPure $ lift $ lift $ put ps

-- | Modify the underlying state of the @'PandocPure'@ type.
modifyPureState :: (PureState -> PureState) -> PandocPure ()
modifyPureState f = PandocPure $ lift $ lift $ modify f

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

-- | Basis of the mock file system used by @'PandocPure'@.
newtype FileTree = FileTree { unFileTree :: M.Map FilePath FileInfo }
  deriving (Semigroup, Monoid)

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

-- | Add the specified file to the FileTree. If file
-- is a directory, add its contents recursively.
addToFileTree :: FileTree -> FilePath -> IO FileTree
addToFileTree tree fp = do
  isdir <- doesDirectoryExist fp
  if isdir
     then do -- recursively add contents of directories
       let isSpecial ".." = True
           isSpecial "."  = True
           isSpecial _    = False
       fs <- map (fp </>) . filter (not . isSpecial) <$> getDirectoryContents fp
       foldM addToFileTree tree fs
     else do
       contents <- B.readFile fp
       mtime <- Directory.getModificationTime fp
       return $ insertInFileTree fp FileInfo{ infoFileMTime = mtime
                                            , infoFileContents = contents } tree

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

newtype PandocPure a = PandocPure {
  unPandocPure :: ExceptT PandocError
                  (StateT CommonState (State PureState)) a
  } deriving ( Functor
             , Applicative
             , Monad
             , MonadError PandocError
             )

-- | Run a 'PandocPure' operation.
runPure :: PandocPure a -> Either PandocError a
runPure x = flip evalState def $
            flip evalStateT def $
            runExceptT $
            unPandocPure x

instance PandocMonad PandocPure where
  lookupEnv s = do
    env <- getsPureState stEnv
    return (lookup s env)

  getCurrentTime = getsPureState stTime

  getCurrentTimeZone = getsPureState stTimeZone

  newStdGen = do
    oldGen <- getsPureState stStdGen
    let (genToStore, genToReturn) = split oldGen
    modifyPureState $ \st -> st { stStdGen = genToStore }
    return genToReturn

  newUniqueHash = do
    uniqs <- getsPureState stUniqStore
    case uniqs of
      u : us -> do
        modifyPureState $ \st -> st { stUniqStore = us }
        return u
      _ -> throwError $ PandocShouldNeverHappenError
                        "uniq store ran out of elements"
  openURL u = throwError $ PandocResourceNotFound u
  readFileLazy fp = do
    fps <- getsPureState stFiles
    case infoFileContents <$> getFileInfo fp fps of
      Just bs -> return (BL.fromStrict bs)
      Nothing -> throwError $ PandocResourceNotFound $ T.pack fp
  readFileStrict fp = do
    fps <- getsPureState stFiles
    case infoFileContents <$> getFileInfo fp fps of
      Just bs -> return bs
      Nothing -> throwError $ PandocResourceNotFound $ T.pack fp

  readStdinStrict = getsPureState stStdin

  glob s = do
    FileTree ftmap <- getsPureState stFiles
    return $ filter (match (compile s)) $ M.keys ftmap

  fileExists fp = do
    fps <- getsPureState stFiles
    case getFileInfo fp fps of
         Nothing -> return False
         Just _  -> return True

  getDataFileName fp = return $ "data/" ++ fp

  getModificationTime fp = do
    fps <- getsPureState stFiles
    case infoFileMTime <$> getFileInfo fp fps of
      Just tm -> return tm
      Nothing -> throwError $ PandocIOError (T.pack fp)
                    (userError "Can't get modification time")

  getCommonState = PandocPure $ lift get
  putCommonState x = PandocPure $ lift $ put x

  logOutput _msg = return ()