spellbinder.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc
#! nix-shell -p "haskellPackages.ghcWithPackages (ps: [ ps.dhall ps.extra ps.optparse-applicative ps.text ])"

{-# LANGUAGE OverloadedStrings #-}

import Options.Applicative hiding (optional)
import Data.Semigroup ((<>))
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Char
import Data.Functor
import Data.List
import System.FilePath
import Control.Monad.Extra (concatMapM)
import Text.ParserCombinators.ReadP ( char, satisfy, endBy, skipMany
                                    , skipSpaces, (+++), readP_to_S, optional
                                    , manyTill, eof
                                    )
import Dhall (Type, record, field, string, list) --inputFile)
inputFile :: Type a -> FilePath -> IO a
inputFile = error "Only available in recent dhall releases."

data Args = Args { root       :: FilePath
                 , bindFiles  :: [FilePath]
                 , workingDir :: FilePath
                 }

args :: Parser Args
args = Args
    <$> strOption
        ( long "root"
       <> short 'r'
       <> metavar "PATH"
       <> help "Root location of the resultant tree" )
    <*> some (strOption
        ( long "binds"
       <> short 'b'
       <> metavar "PATH"
       <> help "Declarative configuration to realize" ))
    <*> strOption
        ( long "working"
       <> short 'w'
       <> metavar "PATH"
       <> value "./"
       <> help "Working directory where generated fstab files will be stored" )

data Bind = Bind { source :: FilePath
                 , target :: FilePath
                 }

data Binds = Binds { existing  :: [Bind]
                   , necessary :: [Bind]
                   , redundant :: [Bind]
                   }

data DhallBind = DhallBind { dbTarget :: FilePath
                           , dbBinds  :: [FilePath]
                           }

bindRecord :: Type DhallBind
bindRecord = record ( DhallBind <$> field "target" string
                                <*> field "binds" (list string)
                    )

-- We need to canonicalize paths to avoid things like including a trailing
-- slash for the root directory making a difference as to the fstab file
-- generated.
canonicalize :: FilePath -> FilePath
canonicalize fp = undefined

tip :: FilePath -> FilePath
tip = last . splitDirectories

readBinds :: FilePath -> [FilePath] -> IO [Bind]
readBinds rt = concatMapM ((toBinds <$>) . inputFile bindRecord)
  where
    toBinds :: DhallBind -> [Bind]
    toBinds db = map (toBind (dbTarget db)) $ dbBinds db
    toBind :: FilePath -> FilePath -> Bind
    toBind tgt src = Bind { source = src
                          , target = rt </> tgt </> tip src
                          }

fstabSep :: String
fstabSep = "  "

-- Read from fstab because you can't tell what the top of a mounted subtree is.
-- Even if you could a complete traversal for nested bind mounts would be
-- impractical.
-- XXX: Can we do this Stateless?
readMountpoints :: FilePath -> IO [FilePath]
readMountpoints rtFSTab = parseMountpoints <$> readFile rtFSTab
  where
    newline = char '\n'
    notNewline = satisfy (/= '\n')
    notWhiteSpace = satisfy (`notElem` ['\n', '\t', ' '])
    fstabComment = char '#' *> endBy notNewline newline
    irrelevant = skipMany (skipSpaces +++ optional fstabComment)
    fstabEntryMountpoint = irrelevant
                         *> skipMany notWhiteSpace
                         *> skipSpaces
                         *> many notWhiteSpace
                         >>= \mp -> skipMany notNewline
                                    *> newline
                                    $> mp
    parseMountpoints = concatMap fst
      <$> readP_to_S (fstabEntryMountpoint `manyTill` eof)

removeMount :: FilePath -> IO ()
removeMount mountpoint = undefined

removeMountpoint :: FilePath -> IO ()
removeMountpoint mountpoint = undefined

removeBind :: Bind -> IO ()
removeBind bind = removeMount tgt >> removeMountpoint tgt
  where tgt = target bind

createMountpoint :: FilePath -> IO ()
createMountpoint mountpoint = undefined

createBind :: Bind -> IO ()
createBind bind = createMountpoint (target bind)

reconcile :: [FilePath] -> [Bind] -> Binds
reconcile mountpoints binds = undefined

type Rule = String

createRule :: Bind -> Rule
createRule bind =
  intercalate fstabSep [source bind, target bind, "none", "ro,bind"]

replaceFSTab :: FilePath -> [Bind] -> IO ()
-- TODO: include # generated by comment.
replaceFSTab bs = undefined

mountFSTab :: FilePath -> IO ()
mountFSTab = undefined

run :: Args -> IO ()
run as = do
  let canonicalRoot = canonicalize $ root as
  let canonicalWorkingDir = canonicalize $ workingDir as
  let canonicalBinds = map canonicalize $ bindFiles as
  let rootFSTab = canonicalWorkingDir </> canonicalRoot <.> "fstab"
  desiredBinds <- readBinds canonicalRoot canonicalBinds
  mountpoints <- readMountpoints rootFSTab
  let binds = reconcile mountpoints desiredBinds
  mapM_ removeBind (redundant binds)
  mapM_ createBind (necessary binds)
  replaceFSTab rootFSTab (necessary binds <> existing binds)
  mountFSTab rootFSTab

main :: IO ()
main = run =<< execParser opts
  where
    versionOption = infoOption "Spellbinder version 1.0" (long "version" <>
                      short 'V' <> help "Show version")
    opts = info (args <**> helper <**> versionOption)
      ( fullDesc
     <> progDesc "Declaratively manage bind mounts"
     <> header "spellbinder - A declarative bind mount manager" )