Adapt to my latest changes to 'ssh' repo

src/Vervis/Ssh.hs

@@ -35,21 +35,16 @@ import Network.SSH
 import Network.SSH.Channel
 import Network.SSH.Crypto
 import Network.SSH.Session
---import Yesod.Default.Main (LogFunc)
 
 import Vervis.Model
 import Vervis.Settings
 
--- TODO:
--- [ ] See which git commands gitolite SSH supports and see if I can implement
---     them with Hit (i think it was git upload-pack)
-
 type ChannelBase = LoggingT (ReaderT ConnectionPool IO)
 type SessionBase = LoggingT (ReaderT ConnectionPool IO)
---type UserAuthId = PersonId
+type UserAuthId = PersonId
 
-type Channel = ChannelT {-UserAuthId-} ChannelBase
-type Session = SessionT SessionBase {-UserAuthId-} ChannelBase
+type Channel = ChannelT UserAuthId ChannelBase
+type Session = SessionT SessionBase UserAuthId ChannelBase
 type SshChanDB = SqlPersistT Channel
 type SshSessDB = SqlPersistT Session
 
@@ -71,8 +66,8 @@ chanFail wantReply msg = do
     channelError $ unpack msg
     when wantReply channelFail
 
-authorize :: Authorize -> Session Bool -- (AuthResult UserAuthId)
-authorize (Password  _    _)   = return False -- AuthFail
+authorize :: Authorize -> Session (AuthResult UserAuthId)
+authorize (Password  _    _)   = return AuthFail
 authorize (PublicKey name key) = do
     mpk <- runSessDB $ do
         mp <- getBy $ UniquePersonLogin $ pack name
@@ -83,19 +78,19 @@ authorize (PublicKey name key) = do
                 return $ Just (pid, ks)
     case mpk of
         Nothing -> do
-            $logInfoS src "Auth failed: Invalid user"
-            return False -- AuthFail
+            lift $ $logInfoS src "Auth failed: Invalid user"
+            return AuthFail
         Just (pid, keys) -> do
             let eValue (Entity _ v) = v
                 matches =
                     (== key) . blobToKey . fromStrict . sshKeyContent . eValue
             case find matches keys of
                 Nothing -> do
-                    $logInfoS src "Auth failed: No matching key found"
-                    return False -- AuthFail
+                    lift $ $logInfoS src "Auth failed: No matching key found"
+                    return AuthFail
                 Just match -> do
-                    $logInfoS src "Auth succeeded"
-                    return True -- $ AuthSuccess pid
+                    lift $ $logInfoS src "Auth succeeded"
+                    return $ AuthSuccess pid
 
 data Action = UploadPack () deriving Show
 
@@ -109,11 +104,11 @@ runAction _wantReply action =
 
 handle :: Bool -> ChannelRequest -> Channel ()
 handle wantReply request = do
-    $logDebugS src $ pack $ show request
+    lift $ $logDebugS src $ pack $ show request
     case detectAction request of
         Nothing  -> err "Unsupported request"
         Just act -> do
-            $logDebugS src $ pack $ show act
+            lift $ $logDebugS src $ pack $ show act
             res <- runAction wantReply act
             case res of
                 Nothing  -> do
@@ -130,7 +125,7 @@ mkConfig
     :: AppSettings
     -> ConnectionPool
     -> LogFunc
-    -> IO (Config SessionBase ChannelBase {-UserAuthId-})
+    -> IO (Config SessionBase ChannelBase UserAuthId)
 mkConfig settings pool logFunc = do
     keyPair <- keyPairFromFile $ appSshKeyFile settings
     return $ Config