Identity.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE OverloadedStrings #-}
  12
  13 module Identity where
  14
  15 import           Control.Monad             (msum, when)
  16 import           Control.Monad.IO.Class    (liftIO)
  17 import           Control.Monad.Trans       (lift)
  18 import           Control.Monad.Trans.Maybe
  19 import           Data.Maybe                (fromMaybe, mapMaybe)
  20 import           Safe
  21 import           System.Directory          (listDirectory)
  22
  23 import           ANSIColour
  24 import           ClientCert
  25 import           MetaString
  26 import           Mundanities
  27 import           Prompt
  28
  29 data Identity = Identity { identityName :: String, identityCert :: ClientCert }
  30     deriving (Eq,Show)
  31
  32 isTemporary :: Identity -> Bool
  33 isTemporary = null . identityName
  34
  35 normaliseIdName :: String -> Maybe String
  36 normaliseIdName n = headMay (words n)
  37
  38 showIdentity :: MetaString a => Bool -> Identity -> a
  39 showIdentity ansi = showIdentityName ansi . fromString . identityName
  40
  41 showIdentityName :: MetaString a => Bool -> String -> a
  42 showIdentityName ansi name = applyIf ansi (withColourStr Green) $
  43     "[" <> fromString name <> "]"
  44
  45 loadIdentity :: FilePath -> String -> IO (Maybe Identity)
  46 loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName
  47
  48 getIdentity :: Bool -> Bool -> FilePath -> KeyType -> String -> IO (Maybe Identity)
  49 getIdentity _ _ _ tp "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned tp "")
  50 getIdentity interactive ansi idsPath tp idName' = runMaybeT $ do
  51     idName <- MaybeT . return $ normaliseIdName idName'
  52     msum [ MaybeT $ loadIdentity idsPath idName
  53         , do
  54             when interactive . lift $ do
  55                 let keyTypeName = case tp of
  56                         KeyRSA     -> "RSA"
  57                         KeyEd25519 -> "Ed25519"
  58                 putStrLn $ "Creating a new " ++ keyTypeName ++ " identity."
  59                 putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";"
  60                 putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username."
  61                 putStrLn "The common name may be left blank. Use ^C to cancel identity generation."
  62             clientCert <- liftIO . generateSelfSigned tp . fromMaybe "" =<<
  63                 if not interactive then return Nothing else MaybeT (promptLine "Common Name: ")
  64             liftIO $ mkdirhier idsPath
  65             lift $ saveClientCert idsPath idName clientCert
  66             return $ Identity idName clientCert
  67         ]
  68
  69 getIdentityRequesting :: Bool -> FilePath -> IO (Maybe Identity)
  70 getIdentityRequesting ansi idsPath = runMaybeT $ do
  71     liftIO . putStrLn $ "Enter the name of an existing identity to use (tab completes),\n\t" ++
  72         "or a name for a new identity to create and use,\n\t" ++
  73         "or nothing to create and use a temporary anonymous identity,\n\t" ++
  74         "or use ^C to abort."
  75     let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": "
  76     idName <- (fromMaybe "" <$>) . MaybeT $
  77         promptLineWithCompletions prompt =<< listIdentities idsPath
  78     MaybeT $ getIdentity True ansi idsPath KeyRSA idName
  79
  80 listIdentities :: FilePath -> IO [String]
  81 listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path)
  82     where stripCrtExt s = case splitAt (length s - 4) s of
  83             (s', ".crt") -> Just s'
  84             _            -> Nothing