Ghost.hs

module Ghost where

import Control.Monad (filterM, forM_, when)
import System.Directory
  ( doesFileExist, getDirectoryContents, getHomeDirectory
  )
import System.Exit (ExitCode)
import System.FilePath ((</>))
import System.IO (hPutStrLn, withFile, IOMode(WriteMode))
import System.Process (runProcess, waitForProcess)

----------------------------------------------------------------------
-- `authorized_keys` helpers
----------------------------------------------------------------------

-- | Given a username and its public SSH key, return a string
-- that can be appended to a SSH authorized_keys file.
-- The entry establishes the binding between a username and its
-- SSH key, so that the passed command 'knows' who is running it.
-- The command must support the `--user` flag.
authorizedKeysEntry:: String -> String -> String -> String
authorizedKeysEntry username cmd key = concat
  [ "command=\"" ++ cmd ++ " --user=", username, "\""
  , ",no-port-forwarding"
  , ",no-X11-forwarding"
  , ",no-agent-forwarding"
  , ",no-pty "
  , key
  ]

-- | Similar to `authorizedKeysEntry` but for an administrator
-- role. The entry does nothing special (i.e. the user can log
-- in as the ghost user and has full access).
administratorAuthorizedKeysEntry:: String -> String -> String
administratorAuthorizedKeysEntry _ key = key

-- | Read keys from ~/administrator/keys and ~/user/.../keys and generate
-- the ~/.ssh/authorized_keys file, pairing SSH keys and usernames.
refreshAuthorizedKeys :: String -> IO ()
refreshAuthorizedKeys cmd = do
  home <- getHomeDirectory
  let authorizedKeys = home </> ".ssh" </> "authorized_keys"
      administratorKeys = home </> "administrator" </> "keys"
      usersDir = home </> "users"

  withFile authorizedKeys WriteMode $ \h -> do
    b <- doesFileExist administratorKeys
    when b $ do
      content <- readFile administratorKeys
      hPutStrLn h "# Auto-generated by ghost-control."
      hPutStrLn h $ administratorAuthorizedKeysEntry "administrator" content

    dirs_ <- getDirectoryContents usersDir
    dirs <- filterM isUserDirectory dirs_
    forM_ dirs $ \d -> do
      let userKeys = usersDir </> d </> "keys"
      b' <- doesFileExist userKeys
      when b' $ do
        content <- readFile userKeys
        hPutStrLn h $ authorizedKeysEntry d cmd content

    putStrLn $ "Added " ++ show (length dirs) ++ " user keys."

-- | Predicate to test if a filename under ~/users is really a user directory.
isUserDirectory :: FilePath -> IO Bool
isUserDirectory x | '.' `elem` x = return False
isUserDirectory _ = return True -- TODO

----------------------------------------------------------------------
-- Process helper
----------------------------------------------------------------------

runAndWaitProcess :: FilePath -> [String] -> Maybe [(String, String)]
  -> IO ExitCode
runAndWaitProcess cmd arguments env = do
  p <- runProcess cmd arguments Nothing env Nothing Nothing Nothing
  waitForProcess p