Generate invidual key

This commit is contained in:
Filip Gralinski 2022-01-19 10:48:38 +01:00
parent 270d4b2607
commit 3a16a9d0e1
2 changed files with 40 additions and 1 deletions

View File

@ -7,6 +7,10 @@ import Data.Conduit.Binary
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import System.Directory
import System.Process
import System.IO
import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage) import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage)
import Handler.Shared import Handler.Shared
@ -17,6 +21,8 @@ getYourAccountR = do
enableTriggerToken userId (userTriggerToken user) enableTriggerToken userId (userTriggerToken user)
mIndividualKey <- fetchIndividualKey $ userLocalId user
keyS <- runDB $ selectFirst [PublicKeyUser ==. userId] [] keyS <- runDB $ selectFirst [PublicKeyUser ==. userId] []
let key = publicKeyPubkey <$> entityVal <$> keyS let key = publicKeyPubkey <$> entityVal <$> keyS
(formWidget, formEnctype) <- generateFormPost (yourAccountForm (userName user) (userLocalId user) key (userAltRepoScheme user) (userIsAnonymous user)) (formWidget, formEnctype) <- generateFormPost (yourAccountForm (userName user) (userLocalId user) key (userAltRepoScheme user) (userIsAnonymous user))
@ -24,6 +30,34 @@ getYourAccountR = do
setTitle "Your account" setTitle "Your account"
$(widgetFile "your-account") $(widgetFile "your-account")
fetchIndividualKey :: Maybe Text -> Handler (Maybe Text)
fetchIndividualKey Nothing = return Nothing
fetchIndividualKey (Just localId) = do
arenaDir <- arena
let individualKeysDir = arenaDir ++ "/individual-keys"
liftIO $ createDirectoryIfMissing True individualKeysDir
let individualKeyPath = (unpack individualKeysDir) ++ "/" ++ (unpack localId)
let individualComment = (unpack localId) ++ "@gonito"
let individualPubKeyPath = individualKeyPath ++ ".pub"
isKeyGenerated <- liftIO $ doesFileExist individualPubKeyPath
if not isKeyGenerated
then
do
_ <- liftIO $ createProcess (proc "/usr/bin/ssh-keygen" ["-t", "RSA", "-f", individualKeyPath, "-N", "", "-C", individualComment]){
std_err = UseHandle stderr,
std_out = UseHandle stderr}
return ()
else
return ()
fhandle <- liftIO $ openFile individualPubKeyPath ReadMode
contents <- liftIO $ System.IO.hGetContents fhandle
return $ Just $ pack contents
postYourAccountR :: Handler Html postYourAccountR :: Handler Html
postYourAccountR = do postYourAccountR = do
((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing Nothing Nothing Nothing False) ((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing Nothing Nothing Nothing False)
@ -32,6 +66,8 @@ postYourAccountR = do
enableTriggerToken userId (userTriggerToken user) enableTriggerToken userId (userTriggerToken user)
mIndividualKey <- fetchIndividualKey $ userLocalId user
let accountData = case result of let accountData = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing

View File

@ -20,4 +20,7 @@
$maybe token <- userTriggerToken user $maybe token <- userTriggerToken user
<li class="list-group-item">Your token for triggering evaluation is <code>#{token}</code> <li class="list-group-item">Your token for triggering evaluation is <code>#{token}</code>
$nothing $nothing
<li class="list-group-item">Your token for triggering evaluation is not set yet, ask the administrator to do this <li class="list-group-item">Your token for triggering evaluation is not set yet, ask the administrator to do this
$maybe individualKey <- mIndividualKey
<p>If you'd like to give Gonito access to your repo other than hosted at Gonito used the following public key:
<pre>#{individualKey}