content: {-# 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
  