darcsden-1.1: src/SSHServer.hs

{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-}
module Main where

#ifndef SSH_FLAG
main :: IO ()
main = error "darcsden was not built with ssh support"
#else
import Control.Exception as C
import Control.Monad.State
import Data.List (isPrefixOf, stripPrefix)
import Data.Time
import SSH.Channel
import SSH.Crypto
import SSH.Session
import System.Directory (canonicalizePath, doesFileExist)
import System.Environment
import System.FilePath
import System.Process
import qualified Codec.Binary.Base64.String as Base64
import qualified SSH as SSH

import DarcsDen.Settings
import DarcsDen.State.Repository
import DarcsDen.State.User
import DarcsDen.State.Util
import DarcsDen.Util


main :: IO ()
main = do
    putStrLn "checking couchdb..."
    runDB (return ())

    port <- do
        as <- getArgs
        case as of
            (p:_) -> return (fromIntegral (read p :: Int))
            _ -> return 5022
    exists <- doesFileExist sshKeyFilePath
    unless exists $
        error $ "Cannot find required SSH keyfile: " ++ sshKeyFilePath
    kp <- rsaKeyPairFromFile sshKeyFilePath
    startSSH kp port
  where
    sshKeyFilePath = homeDir </> ".ssh" </> "id_rsa"
    startSSH kp = SSH.start
        (SessionConfig
            { scAuthMethods = ["publickey"]
            , scAuthorize = sshAuthorize
            , scKeyPair = kp
            })
        (ChannelConfig
            { ccRequestHandler = channelRequest
            })

sshAuthorize :: Authorize -> Session Bool
sshAuthorize (Password _ _) = return False
sshAuthorize (PublicKey name key) = do
    muser <- getUser name
    case muser of
        Just (User { uKeys = keys }) -> do
            check <- mapM keyMatch keys
            liftIO (putStrLn ("authorizing " ++ name ++ ": " ++ show check))
            return (or check)
        Nothing -> do
            liftIO (putStrLn ("authorization failed for " ++ name))
            return False
  where
    rsaPrefix = "ssh-rsa"
    dsaPrefix = "ssh-dss"

    keyMatch :: String -> Session Bool
    keyMatch k =
        case words k of
            (algo:keyBlob:_) | algo `elem` [rsaPrefix, dsaPrefix] ->
                return $ blobToKey (toBLBS $ Base64.decode keyBlob) == key
            _ -> do
                liftIO (putStrLn ("unknown blob: " ++ k))
                return False

channelRequest :: Bool -> ChannelRequest -> Channel ()
channelRequest wr (Execute cmd) =
    case words cmd of
        ["darcs", "transfer-mode", "--repodir", path] ->
            saneRepo path darcsTransferMode
        ["darcs", "apply", "--all", "--repodir", path] ->
            saneRepo path darcsApply
        ["darcs", "apply", "--all", "--debug", "--repodir", path] ->
            saneRepo path darcsApply
        (initialize:repoName:description) | "init" `isPrefixOf` initialize ->
            if null repoName || not (isSane repoName)
                then errorWith "invalid repository name"
                else saneUser $ \u -> do
                    mr <- getOwnerRepository (uName u, repoName)
                    case mr of
                        Nothing -> do
                            now <- liftIO getCurrentTime
                            newRepository Repository
                                { rID = Nothing
                                , rRev = Nothing
                                , rName = repoName
                                , rOwner = uName u
                                , rDescription = unwords description
                                , rWebsite = ""
                                , rCreated = now
                                , rForkOf = Nothing
                                , rMembers = []
                                , rIsPrivate = False
                                , rIssueTracker = False
                                , rIssueCount = 0
                                , rBuiltPacks = Nothing
                                }
                            finishWith "repository created"
                        Just _ -> errorWith "repository already exists"
        (oblit:repoNameAnd) | "oblit" `isPrefixOf` oblit ->
            case repoNameAnd of
                [] -> errorWith "missing repository argument to obliterate"
                (repoName:_) -> if null repoName || not (isSane repoName)
                    then errorWith "invalid repository name"
                    else saneRepo repoName obliterate
        ["scp", "-f", "--", path] ->
            safePath path scp
        ["scp", "-f", path] ->
            safePath path scp
        _ -> failWith $ "invalid exec request: <" ++ show cmd ++ ">\n"
                        ++ "Available interactive commands:\n"
                        ++ unlines nonDarcsCommands
  where
    nonDarcsCommands :: [String]
    nonDarcsCommands = [ "initialise REPO_NAME DESCRIPTION"
                       , "obliterate REPO_NAME"
                       ]

    failWith :: String -> Channel ()
    failWith msg = do
        channelError msg
        when wr channelFail

    finishWith :: String -> Channel ()
    finishWith msg = do
        channelMessage msg
        when wr channelSuccess
        channelDone

    errorWith :: String -> Channel ()
    errorWith msg = do
        channelError msg
        when wr channelSuccess
        channelDone

    -- verify a path that may be two forms:
    --
    --     foo/         a repository "foo" owned by the current user
    --     USER/foo/    a repository "foo" owned by USER;
    --                  the current user must be a member (or the owner)
    saneRepo :: FilePath -> (Repository -> Channel ()) -> Channel ()
    saneRepo p a = saneUser $ \(User { uName = un }) -> do
        case takeWhile (not . null) . map saneName . splitDirectories $ p of
            [ownerName, repoName] -> do
                mrepo <- getOwnerRepository (ownerName, repoName)
                case mrepo of
                    Just r | un `elem` (rOwner r : rMembers r) -> a r
                    _ -> errorWith "invalid repository"
            [repoName] ->
                getOwnerRepository (un, repoName)
                    >>= maybe (errorWith "invalid repository") a
            _ -> errorWith "invalid target directory"

    safePath :: FilePath -> (FilePath -> Channel ()) -> Channel ()
    safePath p a = saneUser $ \(User { uName = un }) -> do
        cpE <- liftIO $ (Right `fmap` (canonicalizePath $ usersDir </> un </> p))
                        `C.catch` (\(e::IOException) -> return $ Left $ show e)
        case cpE of
          Left e -> errorWith e
          Right cp ->
           case stripPrefix (splitDirectories usersDir) $ takeWhile (not . null) . splitDirectories $ cp of
            Just (ownerName:repoName:_) -> do
                mrepo <- getOwnerRepository (ownerName, repoName)
                case mrepo of
                    Just r | un `elem` (ownerName:rMembers r)->
                        a cp
                    _ -> errorWith "invalid path"

            _ -> errorWith "invalid path"

    -- verify the current user
    saneUser :: (User -> Channel ()) -> Channel ()
    saneUser a = do
        mu <- gets csUser >>= getUser
        maybe (errorWith "invalid user") a mu

    obliterate r = execute . unwords $
        [ "darcs"
        , "obliterate"
        , "--repodir"
        , repoDir (rOwner r) (rName r)
        ]

    darcsTransferMode r = execute . unwords $
        [ "darcs"
        , "transfer-mode"
        , "--repodir"
        , repoDir (rOwner r) (rName r)
        ]

    darcsApply r = execute . unwords $
        [ "darcs"
        , "apply"
        , "--all"
        , "--repodir"
        , repoDir (rOwner r) (rName r)
        ]

    scp path = execute . unwords $ ["scp", "-f", "--", path]

    execute = spawnProcess . runInteractiveCommand
channelRequest wr (Environment var _)
    | var == "LANG" || "LC_" `isPrefixOf` var =
        when wr channelSuccess
channelRequest wr r = do
    channelError $ "this server only accepts exec requests\r\ngot: " ++ show r
    when wr channelFail
#endif