From 8cf0f2502ce4d9113596edc8bffb076c38f4efec Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 6 Mar 2016 11:58:48 +0000 Subject: [PATCH] Implement DB-based SSH authentication --- INSTALL.md | 45 ++++++++++---- config/models | 8 +++ src/Network/SSH/Local.hs | 27 +++++++++ src/Vervis/Application.hs | 11 +++- src/Vervis/Ssh.hs | 120 ++++++++++++++++++++++++++++++++++++++ stack.yaml | 7 ++- vervis.cabal | 3 + 7 files changed, 207 insertions(+), 14 deletions(-) create mode 100644 src/Network/SSH/Local.hs create mode 100644 src/Vervis/Ssh.hs diff --git a/INSTALL.md b/INSTALL.md index 61c40c4..763753c 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,16 +1,41 @@ -TODO really explain how to install.... the stuff below is outdated and -misleading... +Vervis is still in early development. These instructions may be incomplete +and/or slightly outdated. At the time of writing, you can get a running Vervis +instance if you follow the steps below. -Install from Hackage: +Install Darcs, GHC 7.10.3 and a recent `stack` version. - $ cabal install vervis - -Install from unpacked release tarball or source repo: +Download the Vervis repo: + $ darcs get http://hub.darcs.net/fr33domlover/vervis $ cd vervis - $ cabal install -Just play with it without installing: +Download fr33domlover's modified `ssh` package: - $ cabal build - $ cabal repl + $ darcs get http://hub.darcs.net/fr33domlover/ssh + +Update `stack.yaml` to specify that path in the `packages` section: + + $ vim stack.yml + +Install PostgreSQL. You'll need the server and the client library development +files. + + $ sudo apt-get install postgresql # TODO see exactly which pages are needed + +Create a new PostgreSQL user and a new database. + + $ #TODO take this from the vervis ticket I wrote... + +Update `stack.yaml` to specify correct database connection details. + + $ vim stack.yaml + +Build. + + $ stack build --flag vervis:dev + +Run. + + $ stack exec vervis + +Browse to `http://localhost:3000` and have fun. diff --git a/config/models b/config/models index 76c5769..0b6c062 100644 --- a/config/models +++ b/config/models @@ -31,6 +31,14 @@ Person UniquePersonIdent ident UniquePersonLogin login +SshKey + person PersonId + name Text + algo ByteString + content ByteString + + UniqueSshKey person name + Group ident SharerId diff --git a/src/Network/SSH/Local.hs b/src/Network/SSH/Local.hs new file mode 100644 index 0000000..a0442b5 --- /dev/null +++ b/src/Network/SSH/Local.hs @@ -0,0 +1,27 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Network.SSH.Local + ( supportedKeyAlgos + ) +where + +import Prelude + +import Data.ByteString.Char8 (ByteString, pack) +import Network.SSH + +supportedKeyAlgos :: [ByteString] +supportedKeyAlgos = map pack supportedKeyAlgorithms diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 10354cb..472fd04 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -30,6 +30,7 @@ module Vervis.Application ) where +import Control.Concurrent (forkIO) import Control.Monad.Logger (liftLoc, runLoggingT) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) @@ -55,6 +56,8 @@ import Vervis.Handler.Person import Vervis.Handler.Project import Vervis.Handler.Repo +import Vervis.Ssh (runSsh) + -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- comments there for more details. @@ -156,10 +159,11 @@ appMain :: IO () appMain = do -- Get the settings from all relevant sources settings <- loadAppSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime + -- Fall back to compile-time values, set to [] to require values at + -- runtime [configSettingsYmlValue] - -- allow environment variables to override + -- Allow environment variables to override useEnv -- Generate the foundation from the settings @@ -168,6 +172,9 @@ appMain = do -- Generate a WAI Application from the foundation app <- makeApplication foundation + -- [experimental] Run SSH server and pray + forkIO $ runSsh settings (appConnPool foundation) + -- Run the application with Warp runSettings (warpSettings foundation) app diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs new file mode 100644 index 0000000..b5677bb --- /dev/null +++ b/src/Vervis/Ssh.hs @@ -0,0 +1,120 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Ssh + ( runSsh + ) +where + +import Prelude + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask) +import Data.ByteString.Char8 (ByteString, unpack) +import Data.ByteString.Lazy (fromStrict) +import Data.Foldable (find) +import Data.Text (pack) +import Database.Persist +import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool) +import Network.SSH +import Network.SSH.Channel +import Network.SSH.Crypto +import Network.SSH.Session + +import Vervis.Model +import Vervis.Settings + +type ChannelB = ReaderT ConnectionPool IO +type SessionB = ReaderT ConnectionPool IO +type Backend = SqlBackend + +type Channel = ChannelT ChannelB +type Session = SessionT SessionB ChannelB +type SshChanDB = ReaderT Backend Channel +type SshSessDB = ReaderT Backend Session + +runChanDB :: SshChanDB a -> Channel a +runChanDB action = do + pool <- lift ask + runSqlPool action pool + +runSessDB :: SshSessDB a -> Session a +runSessDB action = do + pool <- lift ask + runSqlPool action pool + +chanFail :: Bool -> ByteString -> Channel () +chanFail wantReply msg = do + channelError $ unpack msg + when wantReply channelFail + +authorize :: Authorize -> Session Bool +authorize (Password _ _) = return False +authorize (PublicKey name key) = do + mkeys <- runSessDB $ do + mp <- getBy $ UniquePersonLogin $ pack name + case mp of + Nothing -> return Nothing + Just (Entity pid _p) -> + fmap Just $ selectList [SshKeyPerson ==. pid] [] + case mkeys of + Nothing -> do + liftIO $ putStrLn "[SSH] auth failed: invalid user" + return False + Just keys -> do + let eValue (Entity _ v) = v + matches = + (== key) . blobToKey . fromStrict . sshKeyContent . eValue + case find matches keys of + Nothing -> do + liftIO $ + putStrLn "[SSH] auth failed: no matching key found" + return False + Just match -> do + liftIO $ putStrLn "[SSH] auth succeeded" + return True + +handle :: Bool -> ChannelRequest -> Channel () +handle wantReply request = do + liftIO $ print request + chanFail wantReply "I don't execute any commands yet, come back later" + +ready :: IO () +ready = putStrLn "SSH server component running" + +mkConfig :: AppSettings -> ConnectionPool -> IO (Config SessionB ChannelB) +mkConfig settings pool = do + keyPair <- keyPairFromFile $ appSshKeyFile settings + return $ Config + { cSession = SessionConfig + { scAuthMethods = ["publickey"] + , scAuthorize = authorize + , scKeyPair = keyPair + , scRunBaseMonad = flip runReaderT pool + } + , cChannel = ChannelConfig + { ccRequestHandler = handle + , ccRunBaseMonad = flip runReaderT pool + } + , cPort = fromIntegral $ appSshPort settings + , cReadyAction = ready + } + +runSsh :: AppSettings -> ConnectionPool -> IO () +runSsh settings pool = do + config <- mkConfig settings pool + startConfig config diff --git a/stack.yaml b/stack.yaml index 9c46655..36cafda 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,11 +7,14 @@ resolver: lts-5.1 # Local packages, usually specified by relative directory name packages: -- '.' + - '.' + - '/home/fr33domlover/Repos/other-work/ssh' # Packages to be pulled from upstream that are not in the resolver (e.g., # acme-missiles-0.3) -extra-deps: [] +extra-deps: + - SimpleAES-0.4.2 +# - ssh-0.3.2 # Override default flag values for local packages and extra-deps flags: {} diff --git a/vervis.cabal b/vervis.cabal index a27e420..a9589ab 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -39,6 +39,7 @@ library Data.Git.Local Data.Graph.Inductive.Local Data.List.Local + Network.SSH.Local Vervis.Application Vervis.Field.Person Vervis.Field.Project @@ -60,6 +61,7 @@ library Vervis.Handler.Repo Vervis.Handler.Util Vervis.Path + Vervis.Ssh Vervis.Style -- other-modules: default-extensions: TemplateHaskell @@ -118,6 +120,7 @@ library , persistent-template >= 2.0 && < 2.3 , safe , shakespeare >= 2.0 && < 2.1 + , ssh , template-haskell , text >= 0.11 && < 2.0 , time