{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |

This module exports the basic interface for creating and using the
labeled file system, implemented as a file store. Trusted code should
use 'initializeLIOFS' to set the root of the labeled file system. Moreover,
trusted code should implement all the IO functions in terms of
'createFileTCB', 'createDirectoryTCB', and 'getPathLabelTCB' and
'setPathLabelTCB'.

The current implementation uses the 'Show' and 'Read' instance to
serialize and de-serialize labels, respectively. While this is
inefficient, it make it easy to use tools like /getfattr/ to inspect
the labels of files. In a future version we may modify this
implementation to use binary encoding and/or compression (since
filesystem extended attributes are large, but limited).

-}
module LIO.FS.TCB (
  -- * Initializing labeled filesystem
    initializeLIOFS, withLIOFS 
  , getRootDirTCB
  -- * Handling path labels
  , setPathLabelTCB
  , getPathLabelTCB
  -- * Helpers for creating labeled objects
  , createFileTCB, createBinaryFileTCB
  , createDirectoryTCB
  -- * Filesystem errors
  , FSError(..)
  ) where

import safe Data.Maybe (listToMaybe)
import safe Data.Typeable
import safe qualified Data.ByteString.Char8 as S8
import safe qualified Data.ByteString as S
import safe qualified Data.ByteString.Lazy.Char8 as L8
import safe qualified Data.Digest.Pure.SHA as SHA

import safe Control.Monad
import safe Control.Exception
import safe Control.Concurrent.MVar
import safe qualified Control.Exception as E
                 
import safe System.FilePath
import safe System.Directory
import safe System.IO
import System.IO.Unsafe
import safe System.Xattr

import safe LIO
import safe LIO.Error
import LIO.TCB
 
--
-- Exception thrown by the file store interface
--

-- | Filesystem errors
data FSError = FSRootCorrupt           -- ^ Root structure is corrupt.
             | FSRootInvalid           -- ^ Root is invalid (must be absolute).
             | FSRootExists            -- ^ Root already exists.
             | FSRootNoExist           -- ^ Root does not exists.
             | FSRootNeedLabel         -- ^ Cannot create root, missing label.
             | FSObjNeedLabel          -- ^ FSobjectcannot be created without a label.
             | FSLabelCorrupt FilePath -- ^ Object label is corrupt.
             | FSIllegalFileName       -- ^ Supplied file name is illegal.
      deriving (Eq, Typeable)

instance Exception FSError

instance Show FSError where
  show FSRootCorrupt      = "Root structure is corrupt."
  show FSRootInvalid      = "Root path is invalid, must be absolute."
  show FSRootExists       = "Root already exists."
  show FSRootNoExist      = "Root directory does not exist."
  show FSRootNeedLabel    = "Root cannot be created without a label."
  show (FSLabelCorrupt f) = "Label of " ++ show f ++ " is corrupt/non-existant."
  show FSObjNeedLabel     = "FS object cannot be created without a label."
  show FSIllegalFileName  = "Supplied file name is illegal."

--
-- Handling root of FS
--

magicAttr :: AttrName
magicAttr = "user._lio_magic"

-- | Content written to magic key. 
magicContent :: AttrValue
magicContent = S.pack  [ 0x7f, 0x45, 0x4c, 0x46, 0x01
                       , 0x01, 0x01, 0x00, 0x00, 0x00
                       , 0x00, 0x00, 0x00, 0x00, 0x00
                       , 0x00, 0xde, 0xad, 0xbe, 0xef]

-- | Get the root directory.
getRootDirTCB :: Label l => LIO l FilePath
getRootDirTCB = withContext "getRootDirTCB" $ do ioTCB $ getRoot

-- | Create a file store (i.e., labeled file system) with a given
-- label and root file path.  The path must be an absolute path,
-- otherwise @initializeLIOFS@ throws 'FSRootInvalid'.
-- This function simply returns the label of the filesystem for
-- conveniance.
mkFSTCB :: Label l
        => FilePath      -- ^ Path to the filesystem root
        -> l             -- ^ Label of root
        -> IO l
mkFSTCB path l = do
  unless (isAbsolute path) $ throwIO FSRootInvalid
  -- Create root of filesystem:
  createDirectoryIfMissing False path
  -- Set root label:
  setPathLabelTCB path l
  -- Create magic attribute:
  lsetxattr path magicAttr magicContent CreateMode
  -- Return label:
  return l

-- | Check that the supplied pathis a vaild labeled filesystem root.
-- This function throws:
--
--   * 'FSLabelCorrupt' if the directory does not contain a valid label
--   * 'FSRootCorrupt' if the 'magicAttr' attribute is invalid
--   * 'FSRootNoExist' if the directory does not exist or 'magicAttr' is missing
--
checkFSTCB :: Label l => FilePath -> IO l
checkFSTCB path = do
  -- Path must be absolute
  unless (isAbsolute path) $ throwIO FSRootInvalid
  -- Path must be a directory
  checkDirExists
  -- Check magic attribute:
  checkMagic
  -- Get the label of the root
  getPathLabelTCB path
   where checkMagic = do
           magic <- lgetxattr path magicAttr `E.catch`
                      (\(_:: SomeException) -> throwIO FSRootNoExist)
           unless (magic == magicContent) $ throwIO FSRootCorrupt
         checkDirExists = do
          e <- doesDirectoryExist path
          unless e $ throwIO FSRootNoExist

-- | TVar containing per process filestore root.
rootDir :: MVar (Maybe FilePath)
{-# NOINLINE rootDir #-}
rootDir = unsafePerformIO $ newMVar Nothing

-- | Get the filestore root.
getRoot :: IO FilePath
getRoot = do
  mfp <- readMVar rootDir
  maybe (throwIO FSRootNoExist) return mfp
 
-- | Set the filestore root, throw 'FSRootExists' if already set.
setRoot :: FilePath -> IO ()
setRoot fp = do
  act <- modifyMVarMasked rootDir $ \mfp ->
    case mfp of
      Just _  -> return $ (mfp, throwIO FSRootExists)
      Nothing -> return $ (Just fp, return ())
  act

-- | Initialize filesystem at the given path. The supplied path must
-- be absolute, otherwise @initializeLIOFS@ throw 'FSRootInvalid'.  If
-- the FS has already been created then @initializeLIOFS@ solely
-- verifies that the root directory is not corrupt (see 'checkFSTCB')
-- and returns the label of the root. Otherwise, a new FS is created
-- with the supplied label (see 'mkFSTCB').
--
-- NOTE: This function should only be called once per process.
initializeLIOFS :: Label l => FilePath -> Maybe l -> IO l
initializeLIOFS path ml = do
 unless (isAbsolute path) $ throwIO FSRootInvalid
 exists <- doesDirectoryExist path
 l <- if exists
        then checkFSTCB path `E.catch` (\e -> if e == FSRootNoExist
                                               then mkFSTCB' path
                                               else throwIO e)
        else mkFSTCB' path
 setRoot path
 -- If setRoot fails, we leave the filesystem dirty
 return l
  where mkFSTCB' f = maybe (throwIO FSRootNeedLabel) (mkFSTCB f) ml

-- | Top-level wrapper thatexecutes 'initializeLIOFS' followed by the
-- supplied action.
--
-- NOTE: This function should only be called once per process.
withLIOFS :: Label l => FilePath -> Maybe l -> IO a -> IO a
withLIOFS path ml act = do
  void $ initializeLIOFS path ml
  act
  

--
-- Objects
-- 

-- | Label attribute name.
labelAttr :: AttrName
labelAttr = "user._lio_label"

-- | Hash-of-label attribute name.
labelHashAttr :: AttrName
labelHashAttr = "user._lio_label_sha"

-- | Encode a label into an attribute value.
encodeLabel :: Label l => l -> AttrValue
encodeLabel = S8.pack . show

-- | Descode label from an attribute value.
decodeLabel :: Label l => AttrValue -> Maybe l
decodeLabel = fmap fst . listToMaybe . reads . S8.unpack

-- | Set the label of a given path. This function sets the 'labelAttr'
-- attribute to the encoded label, and the hash to 'labelHashAttr'.
--
-- NOTE: This function takes an arbitrary path, hence must not be
-- available to untrusted code.
setPathLabelTCB :: Label l => FilePath -> l -> IO ()
setPathLabelTCB path l = do
  lsetxattr path labelAttr     lEnc        RegularMode
  lsetxattr path labelHashAttr (hash lEnc) RegularMode
    where lEnc = encodeLabel l
          hash = L8.toStrict . SHA.bytestringDigest . SHA.sha1 . L8.fromStrict

-- | Get the label of a given path. If the object does not have an
-- associated label or the hash of the label and stored-hash are not
-- equal, this function throws 'FSLabelCorrupt'.
--
-- NOTE: This function takes an arbitrary path, hence must not be
-- available to untrusted code.
getPathLabelTCB :: Label l => FilePath -> IO l
getPathLabelTCB path = do
  (b, h) <- throwOnFail $ do b <- lgetxattr path labelAttr
                             h <- lgetxattr path labelHashAttr
                             return (b, h)
  let b' = L8.fromStrict b
      h' = L8.toStrict . SHA.bytestringDigest . SHA.sha1 $ b'
  case decodeLabel b of
    Just l | h == h' -> return l
    _                -> doFail
  where doFail = throwIO $ FSLabelCorrupt path
        throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail)

-- | Create a file object with the given label and return a handle to
-- the new file.
createFileTCB :: Label l => l -> FilePath -> IOMode -> LIO l Handle
createFileTCB l path mode = withContext "createFileTCB" $ ioTCB $ do
  h <- openFile path mode
  setPathLabelTCB path l
  return h

-- | Same as 'createFileTCB' but opens the file in binary mode.
createBinaryFileTCB :: Label l => l -> FilePath -> IOMode -> LIO l Handle
createBinaryFileTCB l path mode = withContext "createBinaryFileTCB" $ioTCB $ do
  h <- openBinaryFile path mode
  setPathLabelTCB path l
  return h

-- | Create a directory object with the given label.
createDirectoryTCB :: Label l => l -> FilePath -> LIO l ()
createDirectoryTCB l path = withContext "createDirectoryTCB" $ ioTCB $ do
  createDirectory path
  setPathLabelTCB path l