{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ConstraintKinds,
             FlexibleInstances,
             FlexibleContexts,
             TypeSynonymInstances,
             MultiParamTypeClasses #-}
{- | 

This module provides a very simple API for interacting with a labeled
filesystem.  Each file and directory hsa an associated label that is
used to track and control the information flowing to/from the
file/directory. The API exposed by this module is analogous to a
subset of the "System.IO" API. We currently do not allow operations on
file handles. Rather, files must be read read and written to in whole
(as strict ByteStrings).

The actual storage of labeled files is handled by the "LIO.FS.TCB"
module.  The filesystem is implemented as a file store in which labels
are associated with files and directories using, extended attributes.

/IMPORTANT:/ To use the labeled filesystem you must use 'withLIOFS'
(or other initializers), otherwise any actions built using the
combinators of this module will crash.

An example use case shown below: 

>  import LIO.FS.Simple
>  import LIO.FS.Simple.DCLabel
>
>  main = withDCFS "/tmp/lioFS" $ evalDC $ do
>    createDirectoryP p lsecrets "secrets"
>    writeFileP p ("secrets" </> "alice" ) "I like Bob!"
>      where p = ...
>            lsecrets = ....
>

The file store for the labeled filesystem (see "LIO.FS.TCB") will
be created in @\/tmp\/lioFS@, but this is transparent and the user
can think of the filesystem as having root @/@. Note that for this to
work the filesystem must be mounted with the @user_xattr@ option.
For example, on GNU/Linux, you can remount your drive:

> mount -o remount -o user_xattr devicename

In the current version of the filesystem, there is no notion of
changeable current working directory in the 'LIO' Monad, nor symbolic
links.

-}
module LIO.FS.Simple (
  -- * Initializing labeled filesystem
    initializeLIOFS, withLIOFS 
  -- * File operations
  , readFile, readFileP
  , writeFile, writeFileP
  , appendFile, appendFileP
  , removeFile, removeFileP
  , labelOfFile, labelOfFileP
  -- * Directory operations
  , getDirectoryContents, getDirectoryContentsP
  , createDirectory, createDirectoryP
  , removeDirectory, removeDirectoryP
  -- * Filesystem errors
  , FSError(..)
  -- * Misc helpers
  , cleanUpPath, taintObjPathP, labelDirectoryRecursively 
  ) where

import Prelude hiding (readFile, writeFile, appendFile)

import safe qualified Data.ByteString.Char8 as S8

import safe Control.Monad
import safe Control.Exception (throwIO)


import safe System.IO (IOMode(..))
import safe qualified System.IO as IO
import safe qualified System.IO.Error as IO
import safe qualified System.Directory as IO
import safe System.FilePath
import safe System.Posix.Files

import safe LIO
import safe LIO.Error
import LIO.TCB
import LIO.FS.TCB


--
-- LIO directory operations
--

-- | Get the contents of a directory. The current label is raised to the
-- join of the current label and that of all the directories traversed to
-- the leaf directory. Note that, unlike the standard Haskell
-- 'getDirectoryContents', we first normalise the path by collapsing all
-- the @..@'s. The function uses 'unlabelFilePath' when raising the
-- current label and thus may throw an exception if the clearance is
-- too low.
-- /Note:/ The current LIO filesystem does not support links.
getDirectoryContents :: MonadLIO l m => FilePath -> m [FilePath]
getDirectoryContents = getDirectoryContentsP noPrivs

-- | Same as 'getDirectoryContents', but uses privileges when raising
-- the current label.
getDirectoryContentsP :: (MonadLIO l m, PrivDesc l p)
                      => Priv p         -- ^ Privilege
                      -> FilePath       -- ^ Directory
                      -> m [FilePath]
getDirectoryContentsP p dir = liftLIO $ withContext "getDirectoryContentsP" $ do
  path <- taintObjPathP p dir
  ioTCB $ IO.getDirectoryContents path

-- | Create a directory at the supplied path with the given label.  The
-- given label must be bounded by the the current label and clearance, as
-- checked by 'guardAlloc'.  The current label (after traversing the
-- filesystem to the directory path) must flow to the supplied label,
-- which must, in turn, flow to the current label as required by
-- 'guardWrite'.
createDirectory :: MonadLIO l m => l -> FilePath -> m ()
createDirectory = createDirectoryP noPrivs

-- | Same as 'createDirectory', but uses privileges when raising the
-- current label and checking IFC restrictions.
createDirectoryP :: (MonadLIO l m, PrivDesc l p)
                 => Priv p      -- ^ Privilege
                 -> l           -- ^ Label of new directory
                 -> FilePath    -- ^ Path of directory
                 -> m ()
createDirectoryP p l file' = liftLIO $ withContext "createDirectoryP" $ do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Check that the label is bounded by the current label and clearance:
  guardAllocP p l
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Get label of containing dir:
  ldir <- ioTCB $ getPathLabelTCB path
  -- Can write to containing dir:
  guardWriteP p ldir
  -- Can still create dir:
  guardAllocP p l
  -- Create actual directory:
  createDirectoryTCB l $ path </> fileName


-- | Same as 'readFile' but uses privilege in opening the file.
readFileP :: (MonadLIO l m, PrivDesc l p)
          => Priv p     -- ^ Privileges
          -> FilePath   -- ^ File to open
          -> m S8.ByteString
readFileP p file' = liftLIO $ withContext "readFileP" $ do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Create actual file path:
  let objPath = path </> fileName
  -- Check if file exists:
  exists <- ioTCB $ IO.doesFileExist objPath
  when (exists) $ do
    -- Get label of file:
    l <- ioTCB $ getPathLabelTCB objPath
    -- Make sure we can read from the file
    taintP p l
  ioTCB $ S8.readFile objPath

-- | Reads a file and returns the contents of the file as a strict
-- ByteString.  The current label is raised to reflect all the
-- traversed directories.  If the file exists it is further raised to
-- the label of the file to reflect the read.
readFile :: MonadLIO l m => FilePath -> m S8.ByteString
readFile = readFileP noPrivs

-- | Same as 'writeFile' but uses privilege when writing to the file.
writeFileP  :: (PrivDesc l p, MonadLIO l m)
            => Priv p -> Maybe l -> FilePath -> S8.ByteString -> m ()
writeFileP p ml file' contents = liftLIO $ withContext "writeFileP" $ do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Check that the supplied label is bounded by current label and clearance:
  maybe (return ()) (guardAllocP p) ml
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Create actual file path:
  let objPath = path </> fileName
  -- Check if file exists:
  exists <- ioTCB $ IO.doesFileExist objPath
  if exists
     then do
       -- Get label of file:
       l <- ioTCB $ getPathLabelTCB objPath
       -- Make sure that the provided label (if any) can flow to this
       -- label: the user of this function may assume that the
       -- supplied label is used to protect the contents, so we should
       -- ensure that they get /at least/ that degree of protection
       case ml of
         Just lopt | not (canFlowTo lopt l) ->
           labelError  "Supplied label does not flow to label of file" [lopt, l]
         _ -> return ()
       -- Make sure we can write to the file:
       guardWriteP p l
       ioTCB $ S8.writeFile objPath contents
     else case ml of
           Nothing -> throwLIO FSObjNeedLabel
           Just l -> do
             -- Get label of containing dir:
             ldir <- ioTCB $ getPathLabelTCB path
             -- Make sure we can write to containing dir:
             guardWriteP p ldir
             -- Make sure that we can still create file
             guardAllocP p l
             -- Write to the file
             bracket (createBinaryFileTCB l objPath WriteMode)
                     (ioTCB . IO.hClose) 
                     (\h -> ioTCB $ S8.hPut h contents)


-- | Given an optional label, file path and string, write the string
-- to the file at specified path. The optional label (which must be
-- bounded by the current label and clearance, as enforced by
-- 'guardAlloc') is used to set the label on the file, if the file
-- does not already exist; otherwise the label must flow to the label
-- of the file. (Supplying a 'Nothing' is the same as 'Just' supplying
-- the current label.) This function ensures that current label is
-- raised to reflect all the traversed directories.  Note that if the
-- file does not already exist, it is further required that the
-- current computation be able to write to the containing directory,
-- as imposed by 'guardWrite'.
writeFile :: MonadLIO l m => Maybe l -> FilePath -> S8.ByteString -> m ()
writeFile = writeFileP noPrivs

-- | Same as 'appendFile' but uses privilege when writing to the file.
appendFileP  :: (PrivDesc l p, MonadLIO l m)
             => Priv p -> FilePath -> S8.ByteString -> m ()
appendFileP p file' contents = liftLIO $ withContext "appendFileP" $ do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Create actual file path:
  let objPath = path </> fileName
  -- Check if file exists:
  exists <- ioTCB $ IO.doesFileExist objPath
  if exists
     then do
       -- Get label of file:
       l <- ioTCB $ getPathLabelTCB objPath
       -- Make sure we can write-only to the file:
       guardAllocP p l
       ioTCB $ S8.appendFile objPath contents
    else throwLIO $ IO.mkIOError IO.doesNotExistErrorType
                                 "appendFileP" Nothing (Just objPath)

-- | Given a file path and string, append the string to the file at
-- specified path. This function ensures that current label is raised
-- to reflect all the traversed directories.  Moreover, it requires
-- that the file this is appending to exists and its label is bounded
-- by the current label and clearance (as enforced by 'guardAlloc').
appendFile :: MonadLIO l m => FilePath -> S8.ByteString -> m ()
appendFile = appendFileP noPrivs

-- | Get the label of a file/director at the supplied file path.  The
-- current label is raised to reflect all the traversed directories.
labelOfFile :: MonadLIO l m => FilePath -> m l
labelOfFile = labelOfFileP noPrivs

-- | Same as 'labelOfFile' but uses privilege in traversing
-- directories.
labelOfFileP :: (MonadLIO l m, PrivDesc l p)
          => Priv p     -- ^ Privileges
          -> FilePath   -- ^ File to get the label of
          -> m l
labelOfFileP p file' = liftLIO $ withContext "labelOfFileP" $ do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Create actual file path:
  let objPath = path </> fileName
  -- Check if file exists:
  exists <- ioTCB $ IO.doesFileExist objPath
  -- Get the label of the file
  if exists 
    then ioTCB $ getPathLabelTCB objPath
    else throwLIO $ IO.mkIOError 
                      IO.doesNotExistErrorType
                     "labelOfFileP" Nothing (Just objPath)

-- | Remove the file at the specified path. The current computation
-- must be able to both write to the file and containing directory.
-- Moreover, the current label is raised to reflect the traversal of
-- directories up to the file.
removeFile :: MonadLIO l m => FilePath -> m ()
removeFile f = liftLIO $ withContext "removeFile" $ 
                 removeFileOrDirP "removeFile" False noPrivs f

-- | Same as 'removeFile', but uses privileges to carry out the
-- actions.
removeFileP :: (MonadLIO l m, PrivDesc l p) => Priv p -> FilePath -> m ()
removeFileP p f = liftLIO $ withContext "removeFileP" $ 
                    removeFileOrDirP "removeFileP" False p f

-- | Same as 'removeFile', but removes a directory.
removeDirectory :: MonadLIO l m => FilePath -> m ()
removeDirectory f = liftLIO $ withContext "removeDirectory" $ 
                      removeFileOrDirP "removeDirectory" True noPrivs f

-- | Same as 'removeDirectory', but uses privileges to carry out the
-- actions.
removeDirectoryP :: (MonadLIO l m, PrivDesc l p) 
            => Priv p -> FilePath -> m ()
removeDirectoryP p f = liftLIO $ withContext "removeDirectoryP" $ 
                         removeFileOrDirP "removeDirectoryP" True p f


-- | Remove a file or directory. See 'removeFile' for a high level
-- description of the underlying actions.
removeFileOrDirP :: PrivDesc l p
                 => String -> Bool -> Priv p -> FilePath -> LIO l ()
removeFileOrDirP ctx isDir p file' = do
  file <- cleanUpPath file'
  let containingDir = takeDirectory file
      fileName      = takeFileName  file
  -- Taint up to containing dir:
  path <- taintObjPathP p containingDir
  -- Get label of containing dir:
  ldir <- ioTCB $ getPathLabelTCB path
  -- Can write to containing dir:
  guardWriteP p ldir
  -- Create actual file path:
  let objPath = path </> fileName
  -- Check if file exists:
  ok <- ioTCB $ exists objPath
  if ok
    then do -- Get label of file:
            l <- ioTCB $ getPathLabelTCB objPath
            -- Make sure we can write to the file:
            guardWriteP p l
            ioTCB $ remove objPath
    else throwLIO $ IO.mkIOError IO.doesNotExistErrorType
                                 ctx Nothing (Just objPath)
    where (exists, remove) = if isDir
                               then (IO.doesDirectoryExist, IO.removeDirectory)
                               else (IO.doesFileExist, IO.removeFile)

--
-- Internal helpers
--

-- | Given a pathname to a labeled filesystem object, traverse all the
-- directories up to the object, while correspondingly raising the
-- current label. Note that if the object or a parent-directory does not
-- exist, an exception will be thrown; the label of the exception will be
-- the join of all the directory labels up to the lookup failure.
--
-- /Note:/ this function cleans up the path before doing the
-- lookup, so e.g., path @/foo/bar/..@ will first be rewritten to @/foo@
-- and thus no traversal to @bar@.  Note that this is a more permissive
-- behavior than forcing the read of @..@ from @bar@.
-- @taintObjPath@ returns this cleaned up path.
taintObjPathP :: (MonadLIO l m, PrivDesc l p)
              => Priv p         -- ^ Privilege 
              -> FilePath  -- ^ Path to object
              -> m FilePath
taintObjPathP p path0 = liftLIO $ do
  -- Clean up supplied path:
  path <- cleanUpPath path0
  -- Get root directory:
  root <- getRootDirTCB
  let dirs = splitDirectories . stripSlash $ path
  -- "Traverse" all directories up to object:
  forM_ ("" : allSubDirs dirs) $ \dir -> do
    l <- ioTCB $ getPathLabelTCB (root </> dir)
    taintP p l
  return $ root </> joinPath dirs

-- | Take a list of directories (e.g., @[\"a\",\"b\",\"c\"]@) and return
-- all the subtrees up to the node (@[\"a\",\"a/b\",\"a/b/c\"]@).
allSubDirs :: [FilePath] -> [FilePath]
allSubDirs dirs = reverse $ allSubDirs' dirs "" []
  where allSubDirs' []       _    acc = acc
        allSubDirs' (dir:[]) pfix acc = (pfix </> dir) : acc
        allSubDirs' (dir:ds) pfix acc = let ndir = pfix </> dir
                                        in allSubDirs' ds ndir (ndir : acc)

-- | Remove any 'pathSeparator's from the front of a file path.
stripSlash :: FilePath -> FilePath 
stripSlash [] = []
stripSlash xx@(x:xs) | x == pathSeparator = stripSlash xs
                     | otherwise          = xx

-- | Class for generating clean filepaths
class CleanUpPath m where
  -- | Cleanup a file path, if it starts out with a @..@, we consider this
  -- invalid as it can be used explore parts of the filesystem that should
  -- otherwise be unaccessible. Similarly, we remove any @.@ from the path.
  cleanUpPath :: FilePath -> m FilePath 

instance CleanUpPath IO where
  cleanUpPath = doit . splitDirectories . normalise . stripSlash
    where doit []          = return []
          doit ("..":_)    = throwIO FSIllegalFileName
          doit (_:"..":xs) = doit xs
          doit (".":xs)    = doit xs
          doit (x:xs)      = (x </>) `liftM` doit xs

instance Label l => CleanUpPath (LIO l) where
  cleanUpPath = ioTCB . cleanUpPath


-- | Label the directory and every file within recursively with the
-- supplied label. Note this funciton expects a full path.
labelDirectoryRecursively :: Label l => l -> FilePath -> IO ()
labelDirectoryRecursively l dir = do
  exists <- IO.doesDirectoryExist dir
  unless exists $ throwIO $ IO.mkIOError IO.doesNotExistErrorType
                                        ctx Nothing (Just dir)
  setPathLabelTCB dir l
  fs <- filter (\f -> f `notElem` [".", ".."]) `liftM` IO.getDirectoryContents dir
  forM_ fs $ \f -> do
    let file = dir </> f
    stat <- getFileStatus file
    case () of
      _ | isRegularFile stat -> setPathLabelTCB file l
      _ | isDirectory stat   -> labelDirectoryRecursively l file
      _ -> throwIO $ IO.mkIOError IO.illegalOperationErrorType ctx
                                  Nothing (Just file)

  where ctx = "labelDirectoryRecursively"