diohsc-0.1.9: Identity.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE OverloadedStrings #-}

module Identity where

import           Control.Monad             (msum, when)
import           Control.Monad.IO.Class    (liftIO)
import           Control.Monad.Trans       (lift)
import           Control.Monad.Trans.Maybe
import           Data.Maybe                (fromMaybe, mapMaybe)
import           Safe
import           System.Directory          (listDirectory)

import           ANSIColour
import           ClientCert
import           MetaString
import           Mundanities
import           Prompt

data Identity = Identity { identityName :: String, identityCert :: ClientCert }
    deriving (Eq,Show)

isTemporary :: Identity -> Bool
isTemporary = null . identityName

normaliseIdName :: String -> Maybe String
normaliseIdName n = headMay (words n)

showIdentity :: MetaString a => Bool -> Identity -> a
showIdentity ansi = showIdentityName ansi . fromString . identityName

showIdentityName :: MetaString a => Bool -> String -> a
showIdentityName ansi name = applyIf ansi (withColourStr Green) $
    "[" <> fromString name <> "]"

loadIdentity :: FilePath -> String -> IO (Maybe Identity)
loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName

getIdentity :: Bool -> Bool -> FilePath -> KeyType -> String -> IO (Maybe Identity)
getIdentity _ _ _ tp "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned tp "")
getIdentity interactive ansi idsPath tp idName' = runMaybeT $ do
    idName <- MaybeT . return $ normaliseIdName idName'
    msum [ MaybeT $ loadIdentity idsPath idName
        , do
            when interactive . lift $ do
                let keyTypeName = case tp of
                        KeyRSA     -> "RSA"
                        KeyEd25519 -> "Ed25519"
                putStrLn $ "Creating a new " ++ keyTypeName ++ " identity."
                putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";"
                putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username."
                putStrLn "The common name may be left blank. Use ^C to cancel identity generation."
            clientCert <- liftIO . generateSelfSigned tp . fromMaybe "" =<<
                if not interactive then return Nothing else MaybeT (promptLine "Common Name: ")
            liftIO $ mkdirhier idsPath
            lift $ saveClientCert idsPath idName clientCert
            return $ Identity idName clientCert
        ]

getIdentityRequesting :: Bool -> FilePath -> IO (Maybe Identity)
getIdentityRequesting ansi idsPath = runMaybeT $ do
    liftIO . putStrLn $ "Enter the name of an existing identity to use (tab completes),\n\t" ++
        "or a name for a new identity to create and use,\n\t" ++
        "or nothing to create and use a temporary anonymous identity,\n\t" ++
        "or use ^C to abort."
    let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": "
    idName <- (fromMaybe "" <$>) . MaybeT $
        promptLineWithCompletions prompt =<< listIdentities idsPath
    MaybeT $ getIdentity True ansi idsPath KeyRSA idName

listIdentities :: FilePath -> IO [String]
listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path)
    where stripCrtExt s = case splitAt (length s - 4) s of
            (s', ".crt") -> Just s'
            _            -> Nothing