Main.hs

--  pi-hoole: lightweight access-control for pijul
--  Copyright (C) 2018 Thomas Letan <contact@thomasletan.fr>
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU Affero General Public License as published
--  by the Free Software Foundation, either version 3 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU Affero General Public License for more details.
--
--  You should have received a copy of the GNU Affero General Public License
--  along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Control.Monad      (filterM)
import           Data.List          (partition)
import           Data.Map.Strict    (Map)
import qualified Data.Map.Strict    as M (adjustWithKey, empty, foldl, insert,
                                          insertWith, member, toList)
import           Data.Maybe         (isJust)
import           Data.Set           (Set)
import qualified Data.Set           as S (foldl, singleton, toList, union)
import           Data.Text          (Text, append)
import qualified Data.Text          as T (pack, strip, unpack)
import qualified Data.Text.IO       as T (putStrLn, readFile)
import           Data.Yaml          (decodeFile)
import           GHC.Generics       (Generic)
import           Options.Generic    (ParseRecord, getRecord)
import           PiHoole            (Configuration, UserName (..))
import           System.Directory   (XdgDirectory (..), doesFileExist,
                                     getXdgDirectory, listDirectory)
import           System.Environment (lookupEnv)
import           System.FilePath    (takeFileName, (</>))
import           System.IO          (hPutStrLn, stderr)
import           Text.Regex.PCRE    ((=~))

-------------------------------------------------------------------------------
data CLI = Generate (Maybe FilePath)
         | License
  deriving (Generic, Show)

instance ParseRecord CLI
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
main :: IO ()
main = getRecord "pi-hoole-cfg" >>= piHooleCfg

  where
    piHooleCfg License = putStrLn license

    piHooleCfg (Generate mdir) = do
      dir <- getKeysDir mdir
      (keys, discarded) <- splitCandidates <$> getPotentialKeys dir

      warn discarded

      generateAuthorizedKeys $ organize keys


    warn (fp:rst) = do
      hPutStrLn stderr $ fp ++ ": not a correct key name"
      warn rst
    warn _ = pure ()
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
generateAuthorizedKeys :: Map UserName (Set FilePath) -> IO ()
generateAuthorizedKeys map = mapM_ (uncurry aux) (M.toList map)
  where
    aux user set = mapM_ (authorization user) (S.toList set)

    authorization :: UserName -> FilePath -> IO ()
    authorization (UserName user) fp = do
      key <- T.strip <$> T.readFile fp
      T.putStrLn $ cmd  user `append` "," `append` options `append` " " `append` key

    options = "no-port-forwarding,no-x11-forwarding,no-agent-forwarding"
    cmd user = "command=\"pi-hoole-shell \\\"." `append` user `append` "\\\" \\\"${SSH_ORIGINAL_COMMAND}\\\"\""

organize :: [FilePath] -> Map UserName (Set FilePath)
organize = foldl aux M.empty
  where
    aux m fp =
      case keyOwner $ takeFileName fp of
        Just user -> M.insertWith S.union user (S.singleton fp) m
        _         -> m

getKeysDir :: Maybe FilePath -> IO FilePath
getKeysDir (Just dir) = pure dir
getKeysDir _          = getXdgDirectory XdgConfig "pi-hoole/keys"

isKey :: FilePath -> Bool
isKey = isJust . keyOwner . takeFileName

getPotentialKeys :: FilePath -> IO [FilePath]
getPotentialKeys dir = fmap (dir </>) <$> listDirectory dir
  >>= filterM doesFileExist

keyOwner :: FilePath -> Maybe UserName
keyOwner key = case key =~ regex of
  [[_, name, _]] -> Just (UserName $ T.pack name)
  _              -> Nothing
  where
    regex :: String
    regex = "^([a-zA-Z]*)(\\.[a-zA-Z]+)?\\.pub$"

splitCandidates :: [FilePath] -> ([FilePath], [FilePath])
splitCandidates = partition isKey

license :: String
license =
  unlines [ "Copyright (C) 2018 Thomas Letan <contact@thomasletan.fr>"
          , ""
          , "This program is free software: you can redistribute it and/or modify"
          , "it under the terms of the GNU Affero General Public License as published"
          , "by the Free Software Foundation, either version 3 of the License, or"
          , "(at your option) any later version."
          , ""
          , "This program is distributed in the hope that it will be useful,"
          , "but WITHOUT ANY WARRANTY; without even the implied warranty of"
          , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
          , "GNU Affero General Public License for more details."
          , ""
          , "You should have received a copy of the GNU Affero General Public License"
          , "along with this program.  If not, see <http://www.gnu.org/licenses/>."
          ]
-------------------------------------------------------------------------------