User.hs

module Craft.User where

import           Control.Lens             hiding (un)
import           Data.List                (intercalate)
import qualified Data.Set                 as S
import           Formatting

import qualified Craft.Group              as Group
import           Craft.Internal
import           Craft.Internal.Helpers
import           Craft.Internal.UserGroup


type Name = UserName


name :: Lens' User Name
name = userName


gid :: Lens' User GroupID
gid = userGroup . Craft.Internal.gid


data UserOptions =
  UserOptions
  { _optName       :: String
  , _optUID        :: Maybe UserID
  , _optComment    :: String

  --, optAllowdupe  :: Bool
  -- Whether to allow duplicate UIDs. Default: False

  , _optGroup      :: Maybe GroupName
  -- ^ The default group for a user

  , _optUserGroup  :: Bool
  -- ^ Create a user group for this user. Default: True

  , _optGroups     :: [GroupName]
  -- ^ Other groups

  , _optHome       :: Path Abs Dir

  , _optCreateHome :: Bool
  -- ^ Create the user's home directory when creating user

  , _optPassword   :: Maybe String

  , _optSalt       :: Maybe String
  -- ^ The salt to use when creating the user's password


  --, password_max_age :: Maybe Int
  --, password_min_age :: Maybe Int

  --, _optLocked     :: Bool
  -- Lock the user's account

  , _optShell      :: Maybe (Path Abs FileP)
  -- User's shell

  , _optSystem     :: Bool
  -- Is the user a system user. Default: False
  }
  deriving (Eq, Show)
makeLenses ''UserOptions


-- Nothing means rely on the system's default behavior
userOptions :: String -> Craft UserOptions
userOptions n = do
  dirName <- parseRelDir n
  return UserOptions
         { _optName       = n
         , _optUID        = Nothing
         , _optComment    = n
         , _optGroup      = Nothing
         , _optUserGroup  = True
         , _optGroups     = []
         , _optHome       = $(mkAbsDir "/home")</>dirName
         , _optCreateHome = True
         , _optPassword   = Nothing
         , _optSalt       = Nothing
         , _optShell      = Nothing
         , _optSystem     = False
         --, _optLocked     = False
         }

systemUserOptions :: String -> Craft UserOptions
systemUserOptions n = do
  uo <- userOptions n
  return $ uo & optHome       .~ $(mkAbsDir "/")
              & optShell      ?~ $(mkAbsFile "/usr/sbin/nologin")
              & optCreateHome .~ False
              & optPassword   ?~ ""
              & optSystem     .~ True
              -- & optLocked     .~ True


userMod :: UserName -> [String] -> Craft ()
userMod (UserName un) args =
  exec_ "usermod" $ args ++ [un]


getUID :: UserName -> Craft (Maybe UserID)
getUID (UserName "root") = return . Just $ UserID 0
getUID (UserName un) =
  exec "id" ["--user", un] >>= \case
    ExecSucc r -> return . Just . UserID . read $ r ^. stdout
    ExecFail _ -> return Nothing


setUID :: UserName -> UserID -> Craft ()
setUID un uid' = userMod un ["--uid", show uid']


setShell :: UserName -> Path Abs FileP -> Craft ()
setShell un shell' = userMod un ["--shell", fromAbsFile shell']


setComment :: UserName -> String -> Craft ()
setComment un comment' = userMod un ["--comment", comment']


setGroup :: UserName -> GroupName -> Craft ()
setGroup un gn =
  Group.fromName gn  >>= \case
    Just g  -> userMod un $ toArg "--gid" (g ^. Craft.Internal.gid)
    Nothing -> $craftError $ formatToString ("setGroup `"%shown%"` `"%shown%"` failed. Group `"%shown%"` not found!") un gn gn


setGroups :: UserName -> [GroupName] -> Craft ()
setGroups _  []  = return ()
setGroups un gns = userMod un ["--groups", intercalate "," $ map show gns]


setHome :: UserName -> Path Abs Dir -> Craft ()
setHome un homepath = userMod un ["--home", fromAbsDir homepath]


ensureUserOpts :: User -> UserOptions -> Craft Bool
ensureUserOpts user UserOptions{..} = do
  let checks =
        [ maybeOpt _optUID     (user^.uid)                   setUID
        , opt      _optComment (user^.userComment)           setComment
        , maybeOpt _optGroup   (user^.userGroup . groupName) setGroup
        , opt      _optHome    (user^.userHome)              setHome
        , maybeOpt _optShell   (user^.userShell)             setShell
        , if sameElems _optGroups (user^.userGroups)
            then setGroups username _optGroups >> return True
            else return False
        --TODO: password, salt, lock
        ] :: [Craft Bool]
  or <$> sequence checks
   where
    username = UserName _optName
    opt :: Eq a => a -> a -> (UserName -> a -> Craft ()) -> Craft Bool
    opt expected actual setter
      | expected == actual = return False
      | otherwise          = setter username expected >> return True
    maybeOpt :: Eq a => Maybe a -> a -> (UserName -> a -> Craft ()) -> Craft Bool
    maybeOpt Nothing _ _                   = return False
    maybeOpt (Just expected) actual setter = opt expected actual setter


sameElems :: Ord a => [a] -> [a] -> Bool
sameElems xs ys = S.fromList xs == S.fromList ys


createUser :: UserOptions -> Craft ()
createUser UserOptions{..} = do
  groupArg <- getGroupArg _optGroup
  exec_ "useradd" $ optsToArgs ++ groupArg ++ groupsArg ++ [show _optName]
 where
  getGroupArg :: Maybe GroupName -> Craft [String]
  getGroupArg Nothing = return []
  getGroupArg (Just gn) =
    Group.fromName gn >>= \case
      Just g  -> return $ toArg "--gid" $ g ^. Craft.Internal.gid
      Nothing -> $craftError $ "Failed to create User `"++_optName++"` " ++ "with group `"++show gn++"`. Group not found!"
  groupsArg = toArg "--groups" $ intercalate "," (map show _optGroups)
  optsToArgs =
    concat
      [ toArg "--uid"         _optUID
      , toArg "--comment"     _optComment
      , toArg "--home"        _optHome
      , toArg "--create-home" _optCreateHome
      , toArgBool "--user-group" "--no-user-group" _optUserGroup
      , toArg "--password"    (encrypt _optSalt _optPassword)
      , toArg "--shell"       _optShell
      , toArg "--system"      _optSystem
      ]


lock :: UserName -> Craft ()
lock un = userMod un ["--lock"]


fromName :: Name -> Craft (Maybe User)
fromName (UserName n) = userFromStr n


fromID :: UserID -> Craft (Maybe User)
fromID = userFromID


--   ___ ___ _____   ___ _____ ___
--  | _ \ _ \_ _\ \ / /_\_   _| __|
--  |  _/   /| | \ V / _ \| | | _|
--  |_| |_|_\___| \_/_/ \_\_| |___|


-- TODO
encrypt :: Maybe String -> Maybe String -> Maybe String
encrypt _ _ = Nothing