Implement DB-based SSH authentication

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.

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
 

src/Network/SSH/Local.hs

@@ -0,0 +1,27 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.SSH.Local
+    ( supportedKeyAlgos
+    )
+where
+
+import Prelude
+
+import Data.ByteString.Char8 (ByteString, pack)
+import Network.SSH
+
+supportedKeyAlgos :: [ByteString]
+supportedKeyAlgos = map pack supportedKeyAlgorithms

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
 

src/Vervis/Ssh.hs

@@ -0,0 +1,120 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

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: {}

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