Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 219 lines (203 sloc) 8.205 kb
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
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}

{- | Functions for embedding a gitit wiki into a Happstack application.

The following is a minimal standalone wiki program:

> import Network.Gitit
> import Happstack.Server.SimpleHTTP
>
> main = do
> conf <- getDefaultConfig
> createStaticIfMissing conf
> createTemplateIfMissing conf
> createRepoIfMissing conf
> initializeGititState conf
> simpleHTTP nullConf{port = 5001} $ wiki conf

Here is a more complex example, which serves different wikis
under different paths, and uses a custom authentication scheme:

> import Network.Gitit
> import Control.Monad
> import Text.XHtml hiding (dir)
> import Happstack.Server.SimpleHTTP
>
> type WikiSpec = (String, FileStoreType, PageType)
>
> wikis = [ ("markdownWiki", Git, Markdown)
> , ("latexWiki", Darcs, LaTeX) ]
>
> -- custom authentication
> myWithUser :: Handler -> Handler
> myWithUser handler = do
> -- replace the following with a function that retrieves
> -- the logged in user for your happstack app:
> user <- return "testuser"
> localRq (setHeader "REMOTE_USER" user) handler
>
> myAuthHandler = msum
> [ dir "_login" $ seeOther "/your/login/url" $ toResponse ()
> , dir "_logout" $ seeOther "/your/logout/url" $ toResponse () ]
>
> handlerFor :: Config -> WikiSpec -> ServerPart Response
> handlerFor conf (path', fstype, pagetype) = dir path' $
> wiki conf{ repositoryPath = path'
> , repositoryType = fstype
> , defaultPageType = pagetype}
>
> indexPage :: ServerPart Response
> indexPage = ok $ toResponse $
> (p << "Wiki index") +++
> ulist << map (\(path', _, _) -> li << hotlink (path' ++ "/") << path') wikis
>
> main = do
> conf <- getDefaultConfig
> let conf' = conf{authHandler = myAuthHandler, withUser = myWithUser}
> forM wikis $ \(path', fstype, pagetype) -> do
> let conf'' = conf'{ repositoryPath = path'
> , repositoryType = fstype
> , defaultPageType = pagetype
> }
> createStaticIfMissing conf''
> createRepoIfMissing conf''
> createTemplateIfMissing conf'
> initializeGititState conf'
> simpleHTTP nullConf{port = 5001} $
> (nullDir >> indexPage) `mplus` msum (map (handlerFor conf') wikis)

-}

module Network.Gitit (
                     -- * Wiki handlers
                       wiki
                     , reloadTemplates
                     , runHandler
                     -- * Initialization
                     , module Network.Gitit.Initialize
                     -- * Configuration
                     , module Network.Gitit.Config
                     , loginUserForm
                     -- * Types
                     , module Network.Gitit.Types
                     -- * Tools for building handlers
                     , module Network.Gitit.Framework
                     , module Network.Gitit.Layout
                     , module Network.Gitit.ContentTransformer
                     , getFileStore
                     , getUser
                     , getConfig
                     , queryGititState
                     , updateGititState
                     )
where
import Network.Gitit.Types
import Network.Gitit.Server
import Network.Gitit.Framework
import Network.Gitit.Handlers
import Network.Gitit.Initialize
import Network.Gitit.Config
import Network.Gitit.Layout
import Network.Gitit.State
        (getFileStore, getUser, getConfig, queryGititState, updateGititState)
import Network.Gitit.ContentTransformer
import Network.Gitit.Authentication (loginUserForm)
import Paths_gitit (getDataFileName)
import Control.Monad.Reader
import Prelude hiding (readFile)
import qualified Data.ByteString.Char8 as B
import System.FilePath ((</>))
import Safe

-- | Happstack handler for a gitit wiki.
wiki :: Config -> ServerPart Response
wiki conf = do
  let static = staticDir conf
  defaultStatic <- liftIO $ getDataFileName $ "data" </> "static"
  -- if file not found in staticDir, we check also in the data/static
  -- directory, which contains defaults
  let staticHandler = withExpiresHeaders $
        fileServeStrict' [] static `mplus` fileServeStrict' [] defaultStatic
  let handlers = [debugHandler | debugMode conf] ++ (authHandler conf : wikiHandlers)
  let fs = filestoreFromConfig conf
  let ws = WikiState { wikiConfig = conf, wikiFileStore = fs }
  if compressResponses conf
     then compressedResponseFilter
     else return ""
  staticHandler `mplus` runHandler ws (withUser conf $ msum handlers)

-- | Like 'fileServeStrict', but if file is not found, fail instead of
-- returning a 404 error.
fileServeStrict' :: [FilePath] -> FilePath -> ServerPart Response
fileServeStrict' ps p = do
  rq <- askRq
  resp <- fileServeStrict ps p
  if rsCode resp == 404 || lastNote "fileServeStrict'" (rqUri rq) == '/'
     then mzero -- pass through if not found or directory index
     else do
       -- turn off compresion filter unless it's text
       case getHeader "Content-Type" resp of
            Just ct | B.pack "text/" `B.isPrefixOf` ct -> return resp
            _ -> ignoreFilters >> return resp

wikiHandlers :: [Handler]
wikiHandlers =
  [ -- redirect /wiki -> /wiki/ when gitit is being served at /wiki
    -- so that relative wikilinks on the page will work properly:
    guardBareBase >> getWikiBase >>= \b -> movedPermanently (b ++ "/") (toResponse ())
  , dir "_user" currentUser
  , dir "_activity" showActivity
  , dir "_go" goToPage
  , dir "_search" searchResults
  , dir "_upload" $ do guard =<< return . uploadsAllowed =<< getConfig
                          msum [ methodOnly GET >> requireUser uploadForm
                                 , methodOnly POST >> requireUser uploadFile ]
  , dir "_random" $ methodOnly GET >> randomPage
  , dir "_index" indexPage
  , dir "_feed" feedHandler
  , dir "_category" categoryPage
  , dir "_categories" categoryListPage
  , dir "_expire" expireCache
  , dir "_showraw" $ msum
      [ showRawPage
      , guardPath isSourceCode >> showFileAsText ]
  , dir "_history" $ msum
      [ showPageHistory
      , guardPath isSourceCode >> showFileHistory ]
  , dir "_edit" $ requireUser (unlessNoEdit editPage showPage)
  , dir "_diff" $ msum
      [ showPageDiff
      , guardPath isSourceCode >> showFileDiff ]
  , dir "_discuss" discussPage
  , dir "_delete" $ msum
      [ methodOnly GET >>
          requireUser (unlessNoDelete confirmDelete showPage)
      , methodOnly POST >>
          requireUser (unlessNoDelete deletePage showPage) ]
  , dir "_preview" preview
  , guardIndex >> indexPage
  , guardCommand "export" >> exportPage
  , methodOnly POST >> guardCommand "cancel" >> showPage
  , methodOnly POST >> guardCommand "update" >>
      requireUser (unlessNoEdit updatePage showPage)
  , showPage
  , guardPath isSourceCode >> methodOnly GET >> showHighlightedSource
  , handleAny
  , notFound =<< (guardPath isPage >> createPage)
  ]

-- | Recompiles the gitit templates.
reloadTemplates :: ServerPart Response
reloadTemplates = do
  liftIO recompilePageTemplate
  ok $ toResponse "Page templates have been recompiled."

-- | Converts a gitit Handler into a standard happstack ServerPart.
runHandler :: WikiState -> Handler -> ServerPart Response
runHandler = mapServerPartT . unpackReaderT

unpackReaderT:: (Monad m)
    => c
    -> (ReaderT c m) (Maybe ((Either b a), FilterFun b))
    -> m (Maybe ((Either b a), FilterFun b))
unpackReaderT st handler = runReaderT handler st
Something went wrong with that request. Please try again.