UserGroup.hs

module Craft.Internal.UserGroup where

import           Control.Lens
import           Data.List                      (intercalate)
import           Data.Maybe                     (fromJust)
import           Text.Megaparsec
import           Text.Megaparsec.String

import           Craft.Internal
import           Craft.Internal.Helpers
import           Craft.Internal.Helpers.Parsing


colon :: Parser Char
colon = char ':'


-- TESTME
passwdParser :: Parser (UserName, UserID, GroupID, String, String, String)
passwdParser = do
  name      <- UserName <$> someTill anyChar colon
  _password <- manyTill anyChar colon
  uid'      <- UserID . read <$> someTill digitChar colon
  gid'      <- GroupID . read <$> someTill digitChar colon
  comment'  <- manyTill anyChar colon
  home'     <- manyTill anyChar colon
  shell'    <- manyTill anyChar end
  return (name, uid', gid', comment', home', shell')


-- TESTME
shadowParser :: Parser String
shadowParser = do
  _name <- someTill anyChar colon
  manyTill anyChar colon


userFromStr :: String -> Craft (Maybe User)
userFromStr nameOrIdStr =
  getent "passwd" nameOrIdStr >>= \case
    ExecFail _ -> return Nothing
    ExecSucc r -> do
      (nameS, uid', gid', comment', home', shell') <-
            parseGetent passwdParser "passwd" nameOrIdStr (r ^. stdout)
      home'' <- parseAbsDir home'
      shell'' <- parseAbsFile shell'
      grp <- fromJust <$> groupFromID gid'
      grps <- getGroups nameS
      s <- $stdoutOrError =<< getent "shadow" (show nameS)
      passwordHash' <- parseGetent shadowParser "shadow" (show nameS) s
      return . Just $ User { _userName         = nameS
                           , _uid              = uid'
                           , _userGroup        = grp
                           , _userGroups       = grps
                           , _userPasswordHash = passwordHash'
                           , _userHome         = home''
                           , _userShell        = shell''
                           , _userComment      = comment'
                           }


getGroups :: UserName -> Craft [GroupName]
getGroups (UserName name) = do
  s <- $stdoutOrError =<< exec "id" ["-nG", name]
  return . map GroupName $ words s


getent :: String -> String -> Craft ExecResult
getent dbase key = exec "getent" [dbase, key]


parseGetent :: Parsec String a -> String -> String -> String -> Craft a
parseGetent parser dbase key input =
  case parse parser (unwords ["getent", dbase, key]) input of
    Left  err -> $craftError $ show err
    Right r   -> return r


userFromID :: UserID -> Craft (Maybe User)
userFromID (UserID n) = userFromStr $ show n


useradd :: User -> Craft ()
useradd User{..} =
  exec_ "useradd" $ args ++ toArg "--gid" (_gid _userGroup)
 where
  args = Prelude.concat
    [ toArg "--uid"      _uid
    , toArg "--comment"  _userComment
    , toArg "--groups"   $ intercalate "," $ map show _userGroups
    , toArg "--home"     (fromAbsDir _userHome)
    , toArg "--password" _userPasswordHash
    , toArg "--shell"    (fromAbsFile _userShell)
    ]


-- TESTME
groupParser :: Parser Group
groupParser = do
  name <- GroupName <$> someTill anyChar colon
  _ <- manyTill anyChar colon
  gid' <- GroupID . read <$> someTill digitChar colon
  members' <- map UserName <$> some alphaNumChar `sepBy` char ','
  return $ Group name gid' members'


groupFromStr :: String -> Craft (Maybe Group)
groupFromStr nameOrIdStr =
  getent "group" nameOrIdStr >>= \case
    ExecFail _ -> return Nothing
    ExecSucc r -> Just <$> parseGetent groupParser "group" nameOrIdStr (r ^. stdout)


groupFromID :: GroupID -> Craft (Maybe Group)
groupFromID (GroupID n )= groupFromStr $ show n