darcs repository web UI and hosting app. This is the main darcsden trunk, which also runs hub.darcs.net. (http://hub.darcs.net)

root / ssh-server / darcsden-ssh.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns, CPP #-}
module Main where

import Control.Exception as C
import Control.Lens (view)
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, getCurrentDirectory)
import System.Environment
import System.FilePath
import System.Process (runInteractiveCommand)
import qualified Codec.Binary.Base64.String as Base64
import qualified SSH as SSH

import DarcsDen.Backend.Permanent ( BP, withBP )
import DarcsDen.Darcs (repoTypeFromString)
import DarcsDen.Settings (withSettings, Settings, homeDir, sshPort)
import DarcsDen.Settings.Production
import DarcsDen.State.FileSystem ( usersDir, isSane, saneName, repoDir )
import DarcsDen.State.Repo
import DarcsDen.State.User
import DarcsDen.State.StateUtils
import DarcsDen.Util


main :: IO ()
main = do
  as <- getArgs
  let readCfgArg :: IO Settings
      readCfgArg = case as of
        ("--config":cfgfile:_) -> do
          settings <- getSettings cfgfile
          return settings
        _ -> do
          cwd <- liftIO getCurrentDirectory
          settings <- getSettings $ cwd ++ [pathSeparator] ++ "darcsden.conf"
          return settings
  settings <- readCfgArg
  withSettings settings $ withBP backendPermanent $ do
    putStrLn "checking permanent backend..."
    runBackendPermanentM (return ())

    exists <- doesFileExist sshKeyFilePath
    unless exists $
        error $ "Cannot find required SSH keyfile: " ++ sshKeyFilePath
    kp <- rsaKeyPairFromFile sshKeyFilePath
    startSSH kp sshPort
  where
    sshKeyFilePath :: (?settings :: Settings) => FilePath
    sshKeyFilePath = homeDir </> ".ssh" </> "id_rsa"
    startSSH kp = SSH.start
        (SessionConfig
            { scAuthMethods = ["publickey"]
            , scAuthorize = sshAuthorize
            , scKeyPair = kp
            })
        (ChannelConfig
            { ccRequestHandler = channelRequest
            })

sshAuthorize :: (?settings :: Settings) => Authorize -> Session Bool
sshAuthorize (Password _ _) = return False
sshAuthorize (PublicKey name key) = withBP backendPermanent $ do
    muser <- getUser name
    case muser of
        Just (view 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 :: forall bp . (?settings :: Settings, BP bp) => Bool -> ChannelRequest -> Channel ()
channelRequest wr (Execute cmd) =
    case words cmd of
        ["darcs", "transfer-mode", "--repodir", path] ->
            ifReadableRepo path darcsTransferMode
        ["darcs", "apply", "--all", "--repodir", path] ->
            ifWritableRepo path darcsApply
        ["darcs", "apply", "--all", "--debug", "--repodir", path] ->
            ifWritableRepo path darcsApply
        (initialize:repoName:description) | "init" `isPrefixOf` initialize ->
            doInitialize Nothing repoName description
        (initialize:"--repotype":repoType:repoName:description)
             | "init" `isPrefixOf` initialize ->
            doInitialize (Just repoType) repoName description
        (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 ifWritableRepo 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"
                       , "initialise --repotype REPO_TYPE 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

    ifReadableRepo :: FilePath -> (Repository bp -> Channel ()) -> Channel ()
    ifReadableRepo = ifValidRepoAccess False

    ifWritableRepo :: FilePath -> (Repository bp -> Channel ()) -> Channel ()
    ifWritableRepo = ifValidRepoAccess True

    -- verify that a path (provided with --repodir) points to a valid
    -- repo that is readable or optionally writable by the current
    -- user. We accept only two kinds of path:
    --
    --  REPO        a repository named REPO owned by the current user
    --  OWNER/REPO  a repository named REPO owned by OWNER, and
    --             (for read access) the current user is the owner or a member, or the repo is non-private
    --             (for write access) the current user is the owner or a member
    --
    ifValidRepoAccess :: Bool -> FilePath -> (Repository bp -> Channel ()) -> Channel ()
    ifValidRepoAccess write p a = ifValidUser $ \(view uName -> un) -> do
        case takeWhile (not . null) . map saneName . splitDirectories $ p of
            [ownerName, repoName] -> do
                mrepo <- getOwnerRepository (ownerName, repoName)
                case mrepo of
                    Just r | not (view rIsPrivate r) && not write   -> a r -- a public repo can be read by anyone
                    Just r | un `elem` (view rOwner r : view rMembers r) -> a r -- any repo can be read or written by an owner or member
                    _ -> errorWith "invalid repository"
            [repoName] ->
                getOwnerRepository (un, repoName)
                    >>= maybe (errorWith "invalid repository") a
            _ -> errorWith "invalid target directory"

    safePath :: FilePath -> (FilePath -> Channel ()) -> Channel ()
    safePath p a = ifValidUser $ \(view 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:view rMembers r)->
                        a cp
                    _ -> errorWith "invalid path"

            _ -> errorWith "invalid path"

    -- Do the action if the ssh username matches a darcsden user.
    ifValidUser :: (User bp -> Channel ()) -> Channel ()
    ifValidUser a = do
        mu <- gets csUser >>= getUser
        maybe (errorWith "invalid user") a mu

    doInitialize repoType repoName description =
        if null repoName || not (isSane repoName)
            then errorWith "invalid repository name"
            else ifValidUser $ \u -> do
                mr <- getOwnerRepository (view uName u, repoName)
                case mr of
                    Nothing -> do
                        now <- liftIO getCurrentTime
                        newRepository (repoTypeFromString repoType) $
                            freshRepositoryData
                                repoName (view uName u) [(view uName u)] (unwords description) "" now Nothing []
                                False False 0 0 Nothing
                        finishWith "repository created"
                    Just _ -> errorWith "repository already exists"

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

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

    darcsApply r = execute . unwords $
        [ "darcs"
        , "apply"
        , "--all"
        , "--repodir"
        , repoDir (view rOwner r) (view 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