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 import           System.FilePath
  23
  24 import           ANSIColour
  25 import           ClientCert
  26 import           MetaString
  27 import           Mundanities
  28 import           Prompt
  29
  30 data Identity = Identity { identityName :: String, identityCert :: ClientCert }
  31     deriving (Eq,Show)
  32
  33 isTemporary :: Identity -> Bool
  34 isTemporary = null . identityName
  35
  36 normaliseIdName :: String -> Maybe String
  37 normaliseIdName n = headMay (words n)
  38
  39 showIdentity :: MetaString a => Bool -> Identity -> a
  40 showIdentity ansi = showIdentityName ansi . fromString . identityName
  41
  42 showIdentityName :: MetaString a => Bool -> String -> a
  43 showIdentityName ansi name = applyIf ansi (withColourStr Green) $
  44     "[" <> fromString name <> "]"
  45
  46 loadIdentity :: FilePath -> String -> IO (Maybe Identity)
  47 loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName
  48
  49 identityEnvironment :: FilePath -> Identity -> [(String,String)]
  50 identityEnvironment idsPath (Identity idName _) =
  51     [ ("CLIENT_CERT", idsPath </> idName <.> "crt")
  52     , ("CLIENT_KEY", idsPath </> idName <.> "key")
  53     ]
  54
  55 getIdentity :: Bool -> Bool -> FilePath -> KeyType -> String -> IO (Maybe Identity)
  56 getIdentity _ _ _ tp "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned tp "")
  57 getIdentity interactive ansi idsPath tp idName' = runMaybeT $ do
  58     idName <- MaybeT . return $ normaliseIdName idName'
  59     msum [ MaybeT $ loadIdentity idsPath idName
  60         , do
  61             when interactive . lift $ do
  62                 let keyTypeName = case tp of
  63                         KeyRSA     -> "RSA"
  64                         KeyEd25519 -> "Ed25519"
  65                 putStrLn $ "Creating a new " ++ keyTypeName ++ " identity."
  66                 putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";"
  67                 putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username."
  68                 putStrLn "The common name may be left blank. Use ^C to cancel identity generation."
  69             clientCert <- liftIO . generateSelfSigned tp . fromMaybe "" =<<
  70                 if not interactive then return Nothing else MaybeT (promptLine "Common Name: ")
  71             liftIO $ mkdirhier idsPath
  72             lift $ saveClientCert idsPath idName clientCert
  73             return $ Identity idName clientCert
  74         ]
  75
  76 getIdentityRequesting :: Bool -> FilePath -> IO (Maybe Identity)
  77 getIdentityRequesting ansi idsPath = runMaybeT $ do
  78     liftIO . putStrLn $ "Enter the name of an existing identity to use (tab completes),\n\t" ++
  79         "or a name for a new identity to create and use,\n\t" ++
  80         "or nothing to create and use a temporary anonymous identity,\n\t" ++
  81         "or use ^C to abort."
  82     let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": "
  83     idName <- (fromMaybe "" <$>) . MaybeT $
  84         promptLineWithCompletions prompt =<< listIdentities idsPath
  85     MaybeT $ getIdentity True ansi idsPath KeyRSA idName
  86
  87 listIdentities :: FilePath -> IO [String]
  88 listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path)
  89     where stripCrtExt s = case splitAt (length s - 4) s of
  90             (s', ".crt") -> Just s'
  91             _            -> Nothing