SSH.hs

module Craft.Config.SSH where

import           Control.Lens                   hiding (noneOf)
import           Data.Char                      (toLower)
import           Data.Maybe                     (catMaybes)
import           Text.Megaparsec

import           Craft                          hiding (try)
import           Craft.Config
import           Craft.Internal.Helpers
import           Craft.Internal.Helpers.Parsing
import           Craft.SSH


data Section
  = Host  String Body
  | Match String Body
  deriving Eq


type Sections = [Section]


type Body = [(String, String)]


newtype SSHConfig = SSHConfig { _sshfmt :: Sections }
  deriving Eq


instance Show SSHConfig where
  show sshcfg = unlines . map show $ _sshfmt sshcfg


data UserConfig
  = UserConfig
    { _user        :: User
    , _userConfigs :: SSHConfig
    }
  deriving Eq
makeLenses ''SSHConfig
makeLenses ''UserConfig

instance ConfigFormat SSHConfig where
  showConfig = show
  parseConfig = sshConfigParse


userPath :: UserConfig -> Path Abs FileP
userPath uc = (userDir (uc ^. user) ^. path) </> $(mkRelFile "config")


get :: Path Abs FileP -> Craft (Maybe (Config SSHConfig))
get = Craft.Config.get


bodyLookup :: String -> Body -> Maybe String
bodyLookup key body =
  lookup (map toLower key) $ map ((,) <$> map toLower . fst <*> snd) body


cfgLookup :: String -> String -> SSHConfig -> Maybe String
cfgLookup sectionName key (SSHConfig sections') =
  case body of
    Just b  -> bodyLookup key b
    Nothing -> Nothing
 where
  body = maybeHead . catMaybes $ map f sections'
  f (Host name b) | name == sectionName = Just b
                  | otherwise           = Nothing
  f             _                       = Nothing
  maybeHead []    = Nothing
  maybeHead (x:_) = Just x


instance Craftable UserConfig UserConfig where
  watchCraft cfg = do
    craft_ $ userDir $ cfg ^. user
    w <- watchCraft_ $ file (userPath cfg)
                       & mode          .~ Mode RW O O
                       & ownerAndGroup .~ cfg ^. user
                       & strContent .~ show cfg
    return (w, cfg)


sshConfigParse :: Path Abs FileP -> String -> Craft SSHConfig
sshConfigParse fp s =
  case runParser parser (show fp) s of
    Left err   -> $craftError $ show err
    Right secs -> return $ SSHConfig secs


instance Show UserConfig where
  show uc = show $ uc ^. userConfigs


showBody :: Body -> String
showBody body = indent 4 . unlines $ map (\(n, v) -> n ++ " " ++ v) body


instance Show Section where
  show (Host hostname body) = "Host " ++ hostname ++ "\n" ++ showBody body
  show (Match match body)   = "Match " ++ match ++ "\n" ++ showBody body


parseTitle :: Parsec String (String, String)
parseTitle = do
  space
  type' <- try (string' "host") <|> string' "match"
  void spaceChar
  notFollowedBy eol
  space
  name <- anyChar `someTill` eol
  return (type', name)


parseBody :: Parsec String [(String, String)]
parseBody = many bodyLine


bodyLine :: Parsec String (String, String)
bodyLine = do
  notFollowedBy parseTitle
  space
  name <- someTill anyChar spaceChar
  notFollowedBy eol
  space
  val <- between (char '"') (char '"') (many $ noneOf "\"")
         <|> someTill anyChar end
  void $ optional (space <|> void (many eol))
  return (name, trim val)


parseSection :: Parsec String Section
parseSection = do
  title <- parseTitle
  body <- parseBody
  return $ case map toLower (fst title) of
    "host"  -> Host (snd title) body
    "match" -> Match (snd title) body
    _       -> error "Craft.Config.SSH.parse failed. This should be impossible."


parser :: Parsec String Sections
parser = some parseSection