Handler.hs

{-# LANGUAGE OverloadedStrings #-}
module DarcsDen.Handler where

import Control.Applicative ((<|>))
import Control.Arrow (second)
import Control.Concurrent (threadDelay)
import Control.Monad.Trans
import Data.Monoid (mconcat)
import qualified Darcs.Repository as R
import qualified Darcs.Patch.V1.Core as P
import qualified Darcs.Patch.Prim.V1.Core as Pr
import Snap.Core
import Snap.Util.FileServe
import System.FilePath ((</>))
import qualified Data.Text as T
import qualified Data.ByteString as BS

import DarcsDen.Handler.Repository
import DarcsDen.Handler.Repository.Util (getRepo)
import DarcsDen.Handler.User
import DarcsDen.Settings
import DarcsDen.State.Repository
import DarcsDen.State.Session
import DarcsDen.State.User
import DarcsDen.State.Util
import DarcsDen.Util
import DarcsDen.WebUtils
import qualified DarcsDen.Pages.Base as Base

-- URL handling
handler :: FilePath -> Snap ()
handler cwd =
    route
        [ ("public", serveDirectory $ cwd </> "public")
        , ("robots.txt", serveFile $ cwd </> "public/robots.txt")
        , ("favicon.ico", serveFile $ cwd </> "public/images/favicon.ico")
        , (":user/:repo/_darcs", repoServe "_darcs")
        , (":user/:repo/raw", repoServe "")
        , ("delay/:seconds", dbgDelay)
        ] <|>
    withSession (\s -> ifTop (frontpage s) <|> route (routes s))

routes :: Session -> [(BS.ByteString, Snap ())]
routes s =
    [ -- Main
      ("explore", explore s)
    , ("explore/page/:page", explore s)
    , ("init", method GET (initialize s) <|> method POST (doInitialize s))

    -- Users
    , (":user", user s)
    ]
    ++ (if multiuser
        then [ ("register", method GET (register s) <|> method POST (doRegister s))
             , ("register/github", githubRegister s)
             , ("register/github/response", githubRegisterResponse s)
             , ("register/google", googleRegister s)
             , ("register/google/response", googleRegisterResponse s)
             ] 
        else [])
    ++ [
      ("login/github", githubLogin s)
    , ("login/github/response", githubLoginResponse s)
    , ("login/google", googleLogin s)
    , ("login/google/response", googleLoginResponse s)
    , ("login", method GET (login s) <|> method POST (doLogin s))
    , ("logout", logout s)
    , ("settings", method GET (settings s) <|> method POST (doSettings s))
    , ("forgotpassword", method GET (forgotPassword s) <|> method POST (forgotPasswordResponse s))
    , ("recovery", method GET (resetPassword s) <|> method POST (resetPasswordResponse s))
    , ("sync/github", syncWithGithub s)
    , ("sync/github/response", syncWithGithubResponse s)
    , ("sync/google", syncWithGoogle s)
    , ("sync/google/response", syncWithGoogleResponse s)
    ] ++

    -- Repositories
    map (second (validateRepo s)) (
        [ (":user/:repo", browseRepo)
        , (":user/:repo/browse", browseRepo)
        , (":user/:repo/edit-file", \u r s' ->
            method GET (editFile u r s') <|>
            method POST (editFilePost u r s'))
	, (":user/:repo/add-file", \u r s' ->
            method GET (addFile u r s') <|>
            method POST (addFilePost u r s'))
        , (":user/:repo/changes", repoChanges)
        , (":user/:repo/changes/atom", repoChangesAtom)
        , (":user/:repo/changes/page/:page", repoChanges)
        , (":user/:repo/delete", \u r s' ->
            method GET (deleteRepo u r s') <|>
            method POST (doDeleteRepo u r s'))
        , (":user/:repo/edit", \u r s' ->
            method GET (editRepo u r s') <|>
            method POST (doEditRepo u r s'))
        , (":user/:repo/packs", buildPacks)
        , (":user/:repo/fork", forkRepo)
        , (":user/:repo/fork-as", forkRepoAs)
        , (":user/:repo/patches", repoPatches)
        , (":user/:repo/merge", repoMerge)
        -- , (":user/:repo/patch1/:id", repoPatch1)
        , (":user/:repo/patch/:id", repoPatch)
        , (":user/:repo/renderedpatch/:id", renderedpatch)
        ]
        ++ if issuetrackers then
        [ (":user/:repo/issues", repoIssuesOpen)
        , (":user/:repo/issues/closed", repoIssuesClosed)
        , (":user/:repo/issues/all", repoIssuesAll)
        , (":user/:repo/issues/tag/:tag", repoIssuesTag)
        , (":user/:repo/issue/:number", repoIssue)
        , (":user/:repo/issue/:number/comment", repoComment)
        , (":user/:repo/new-issue", \u r s' ->
            method GET (newIssue u r s') <|>
            method POST (doNewIssue u r s'))
        ]
        else []
        )

dbgDelay :: Snap ()
dbgDelay = do
    Just delay <- getParam "seconds"
    let s = read $ fromBS delay
        s' = max s 300
    liftIO $ threadDelay $ s' * 1000000
    writeText $ mconcat [T.pack $ show s', "s delay complete"]

frontpage :: Page
frontpage s = do
    us <- getUsers
    doPage (Base.frontpage us) s

validateRepo :: Session -> (User -> Repository -> Page) -> Snap ()
validateRepo s p = do
    mo <- getParam "user"
    mn <- getParam "repo"

    case (mo, mn) of
        (Just o, Just n) -> do
            let (owner, name) = (fromBS o, fromBS n)
            mu <- getUser owner
            mr <- getValidRepo owner name
            darcsRepo <- liftIO (getRepo (repoDir owner name)) :: Snap (Either String (R.Repository (P.Patch Pr.Prim) wR wU wT))
            case (mu, mr, darcsRepo) of
                (Just u , Just r , Right _) -> p u r s
                (Nothing, _      , _      ) -> notFoundPage "user does not exist"
                (_      , Just _ , Left _ ) -> notFoundPage "repository invalid"
                (Just _ , Nothing, _      ) -> notFoundPage "repository does not exist"
        _ -> warn "no repository specified" s >> redirectTo baseUrl
  where
    getValidRepo owner name = do
        public <- getRepository (owner, name)

        -- repository is public
        if public /= Nothing
            then return public
            else do

        -- repository is private
        case sUser s of
            -- owner viewing their own repository
            Just un | un == owner ->
                getOwnerRepository (owner, name)

            -- some other user, check if they're a member
            Just mn -> do
                mm <- getUser mn
                case mm of
                    Just (User { uName = un }) -> do
                        ism <- isMember un (owner, name)
                        if ism
                            then getOwnerRepository (owner, name)
                            else return Nothing

                    -- invalid user
                    _ -> return Nothing

            -- not logged in
            _ -> return Nothing