GHC-Options:
-fwarn-unused-imports
Build-Depends:
- base, network, unix, encoding, base64-string, hxt, HsSVN, Lucu
+ base, mtl, network, unix, encoding, base64-string, hxt, HsSVN, Lucu
Exposed-Modules:
Rakka.Page
Rakka.Storage
module Rakka.Environment
( Environment(..)
, setupEnv
+
+ , getSiteName
+ , getSiteNameA
+
+ , getBaseURI
+ , getBaseURIA
)
where
+import Control.Arrow.ArrowIO
+import qualified Data.ByteString.Char8 as C8
+import Data.Maybe
import Network
import qualified Network.HTTP.Lucu.Config as LC
+import Network.URI
import Rakka.Storage
envLocalStateDir = lsdir
, envLucuConf = lucuConf
, envStorage = storage
- }
\ No newline at end of file
+ }
+
+
+getSiteName :: Environment -> IO String
+getSiteName env
+ = return "Rakka" -- FIXME
+
+
+getSiteNameA :: ArrowIO a => Environment -> a b String
+getSiteNameA = arrIO0 . getSiteName
+
+
+getBaseURI :: Environment -> IO URI
+getBaseURI env
+ = do let conf = envLucuConf env
+ host = C8.unpack $ LC.cnfServerHost conf
+ port = case LC.cnfServerPort conf of
+ PortNumber num -> fromIntegral num
+
+ defaultURI
+ = "http://" ++ host ++
+ (if port == 80
+ then ""
+ else ':' : show port) ++ "/"
+
+ return $ fromJust $ parseURI defaultURI -- FIXME
+
+
+getBaseURIA :: ArrowIO a => Environment -> a b URI
+getBaseURIA = arrIO0 . getBaseURI
\ No newline at end of file
( PageName
, Page(..)
, encodePageName
+ , decodePageName
+ , mkPageURI
)
where
import Network.HTTP.Lucu
import Network.URI
import Subversion.Types
+import System.Time
type PageName = String
data Page
- = Redirect PageName
- | Page {
+ = Redirection {
+ redirName :: PageName
+ , redirDest :: PageName
+ , redirRevision :: Maybe RevNum
+ , redirLastMod :: CalendarTime
+ }
+ | Entity {
pageName :: PageName
, pageType :: MIMEType
, pageIsTheme :: Bool -- text/css 以外では無意味
, pageIsLocked :: Bool
, pageIsBoring :: Bool
, pageRevision :: Maybe RevNum
+ , pageLastMod :: CalendarTime
, pageSummary :: Maybe String
, pageOtherLang :: [(String, PageName)]
, pageContent :: LazyByteString
shouldEscape c
| c >= ' ' && c <= '~' = False
| otherwise = True
+
+
+-- URI unescape して UTF-8 から decode する。
+decodePageName :: FilePath -> PageName
+decodePageName = decode UTF8 . C8.pack . unEscapeString
+
+
+mkPageURI :: URI -> PageName -> URI
+mkPageURI baseURI name
+ | uriPath baseURI == "" = baseURI { uriPath = "/" ++ encoded }
+ | uriPath baseURI == "/" = baseURI { uriPath = "/" ++ encoded }
+ | last (uriPath baseURI) == '/' = baseURI { uriPath = uriPath baseURI ++ encoded }
+ | otherwise = baseURI { uriPath = uriPath baseURI ++ "/" ++ encoded }
+ where
+ encoded = encodePageName name
--- /dev/null
+module Rakka.Resource
+ ( runIdempotentA
+ , outputXmlPage
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Monad
+import Control.Monad.Trans
+import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
+import Network.URI
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+-- / ==> /
+-- /foo ==> /foo.html
+-- /foo/ ==> /foo.html
+-- /foo.bar/ ==> /foo.bar
+-- /foo.bar ==> /foo.bar
+canonicalizeURI :: Resource ()
+canonicalizeURI
+ = do uri <- getRequestURI
+ let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
+ newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
+ [] -> []
+ path -> case break (== '.') $ last path of
+ (_, "") -> let basePieces = reverse $ tail $ reverse path
+ lastPiece = last path
+ in
+ basePieces ++ [lastPiece ++ ".html"]
+ (_, _) -> path
+ when (uri /= newURI)
+ $ abort MovedPermanently
+ [("Location", uriToString id newURI $ "")]
+ Nothing
+
+
+runIdempotentA :: IOSArrow () (Resource c) -> Resource c
+runIdempotentA a
+ = do canonicalizeURI
+ [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA ()
+ >>>
+ a
+ )
+ rsrc
+
+
+getEntityType :: Resource MIMEType
+getEntityType
+ = do uri <- getRequestURI
+ let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
+ case lookup ext extMap of
+ Just mType -> return mType
+ Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
+ where
+ extMap :: [(String, MIMEType)]
+ extMap = [ ("html", read "application/xhtml+xml")
+ , ( "xml", read "text/xml" )
+ ]
+
+
+outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
+outputXmlPage tree toXHTML
+ = do mType <- getEntityType
+ setContentType mType
+ let formatter = if mType == read "text/xml" then
+ this
+ else
+ toXHTML
+ [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA tree
+ >>>
+ formatter
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output resultStr
\ No newline at end of file
import Data.Char
import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
import Rakka.Environment
+import Rakka.Page
+import Rakka.Resource.Page.Get
fallbackPage :: Environment -> [String] -> IO (Maybe ResourceDef)
= return $ Just $ ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
- , resGet = Just $ handleGet env path
+ , resGet = Just $ handleGet env (toPageName path)
, resHead = Nothing
, resPost = Nothing
- , resPut = Just $ handlePut env path
- , resDelete = Just $ handleDelete env path
+ , resPut = Just $ handlePut env (toPageName path)
+ , resDelete = Just $ handleDelete env (toPageName path)
}
-handleGet :: Environment -> [String] -> Resource ()
-handleGet = fail "FIXME: not implemented"
+toPageName :: [String] -> PageName
+toPageName = decodePageName . joinWith "/"
-handlePut :: Environment -> [String] -> Resource ()
+handlePut :: Environment -> PageName -> Resource ()
handlePut = fail "FIXME: not implemented"
-handleDelete :: Environment -> [String] -> Resource ()
+handleDelete :: Environment -> PageName -> Resource ()
handleDelete = fail "FIXME: not implemented"
--- /dev/null
+module Rakka.Resource.Page.Get
+ ( handleGet
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Network.HTTP.Lucu
+import Network.URI
+import Rakka.Environment
+import Rakka.Page
+import Rakka.Resource
+import Rakka.Storage
+import Rakka.Utils
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+
+
+{-
+ [リダイレクトの場合]
+ HTTP/1.1 302 Found
+ Location: http://example.org/Destination?from=Source&revision=112
+
+ <page site="CieloNegro"
+ baseURI="http://example.org/"
+ name="Source"
+ redirect="Destination"
+ revision="112" -- デフォルトでない場合のみ存在
+ lastModified="2000-01-01T00:00:00" />
+
+
+ [text/* の場合]
+
+ <page site="CieloNegro"
+ baseURI="http://example.org/"
+ name="Foo/Bar"
+ type="text/x-rakka"
+ isTheme="no" -- text/css の場合のみ存在
+ isFeed="no" -- text/x-rakka の場合のみ存在
+ isLocked="no"
+ revision="112"> -- デフォルトでない場合のみ存在
+ lastModified="2000-01-01T00:00:00" />
+
+ <summary>
+ blah blah...
+ </summary> -- 存在しない場合もある
+
+ <otherLang>
+ <link lang="ja" page="Bar/Baz" />
+ </otherLang>
+
+ <content>
+ blah blah...
+ </content>
+ </page>
+
+
+ [text/* 以外の場合: content 要素の代はりに object 要素]
+
+ <object data="/object/Foo/Bar" /> -- data 屬性に URI
+-}
+handleGet :: Environment -> PageName -> Resource ()
+handleGet env name
+ = let sto = envStorage env
+ in
+ runIdempotentA $ proc ()
+ -> do siteName <- getSiteNameA env -< ()
+ baseURI <- getBaseURIA env -< ()
+
+ pageM <- getPageA sto -< name
+ case pageM of
+ Nothing
+ -> returnA -< foundNoEntity Nothing
+
+ Just redir@(Redirection _ _ _ _)
+ -> do tree <- ( eelem "/"
+ += ( eelem "page"
+ += sattr "site" siteName
+ += sattr "baseURI" (uriToString id baseURI "")
+ += sattr "name" name
+ += sattr "redirect" (redirDest redir)
+ += ( case redirRevision redir of
+ Nothing -> none
+ Just rev -> sattr "revision" (show rev)
+ )
+ += sattr "lastModified" (formatW3CDateTime $ redirLastMod redir)
+ )
+ ) -<< ()
+ returnA -< do redirect SeeOther (mkPageURI baseURI name)
+ outputXmlPage tree redirToXHTML
+
+
+redirToXHTML :: ArrowXml a => a XmlTree XmlTree
+redirToXHTML = error "not implemented"
\ No newline at end of file
, mkStorage -- private
, getPage
- , savePage
+ , putPage
+
+ , getPageA
+ , putPageA
)
where
+import Control.Arrow.ArrowIO
import Rakka.Page
import Rakka.Storage.DefaultPage
+import Subversion.Types
data Storage = Storage -- FIXME
= loadDefaultPage name -- FIXME
-savePage :: Storage -> PageName -> Page -> IO ()
-savePage sto name page
+putPage :: Storage -> Maybe RevNum -> Page -> IO ()
+putPage sto oldRev page
= error "FIXME: not implemented"
+
+
+getPageA :: ArrowIO a => Storage -> a PageName (Maybe Page)
+getPageA = arrIO . getPage
+
+
+putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) ()
+putPageA = arrIO2 . putPage
\ No newline at end of file
import qualified Codec.Binary.Base64.String as B64
import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy.Char8 as L8
import Paths_Rakka -- Cabal が用意する。
import Rakka.Page
import Rakka.Utils
import System.Directory
+import System.Time
import Text.XML.HXT.Arrow.ReadDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
loadPageFile :: PageName -> FilePath -> IO Page
loadPageFile name path
- = do [page] <- runX ( constA (name, path)
+ = do [page] <- runX ( setErrorMsgHandler False fail
+ >>>
+ constA (name, path)
>>>
loadPageFileA
)
loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
loadPageFileA
= proc (name, fpath) ->
- do tree <- readFromDocument [ (a_validate , v_0)
- , (a_check_namespaces , v_1)
- , (a_remove_whitespace, v_1)
- ] -< fpath
- parsePage -< (name, tree)
+ do tree <- readFromDocument [ (a_validate , v_0)
+ , (a_check_namespaces , v_1)
+ , (a_remove_whitespace, v_1)
+ ] -< fpath
+ lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
+ parsePage -< (name, lastMod, tree)
+
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parsePage
+ = proc (name, lastMod, tree)
+ -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
+ case redirect of
+ Nothing -> parseEntity -< (name, lastMod, tree)
+ Just dest -> returnA -< (Redirection {
+ redirName = name
+ , redirDest = dest
+ , redirRevision = Nothing
+ , redirLastMod = lastMod
+ })
+
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
-parsePage
- = proc (name, tree)
+parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parseEntity
+ = proc (name, lastMod, tree)
-> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
>>> arr read) -< tree
(Just text, _ ) -> L8.pack text
(_ , Just binary) -> L8.pack $ B64.decode binary
- returnA -< Page {
+ returnA -< Entity {
pageName = name
, pageType = mimeType
, pageIsTheme = isTheme
, pageIsLocked = isLocked
, pageIsBoring = isBoring
, pageRevision = Nothing
+ , pageLastMod = lastMod
, pageSummary = summary
, pageOtherLang = otherLang
, pageContent = content
, maybeA
, defaultTo
, deleteIfEmpty
+ , formatW3CDateTime
)
where
import Control.Arrow
import Control.Arrow.ArrowList
+import System.Time
+import Text.Printf
parseYesOrNo :: ArrowChoice a => a String Bool
deleteIfEmpty
= proc str -> do case str of
"" -> none -< ()
- _ -> returnA -< str
\ No newline at end of file
+ _ -> returnA -< str
+
+
+formatW3CDateTime :: CalendarTime -> String
+formatW3CDateTime time
+ = formatDateTime time ++ formatTimeZone time
+ where
+ formatDateTime :: CalendarTime -> String
+ formatDateTime time
+ = printf "%04d-%02d-%02dT%02d:%02d:%02d"
+ (ctYear time)
+ (fromEnum (ctMonth time) + 1)
+ (ctDay time)
+ (ctHour time)
+ (ctMin time)
+ (ctSec time)
+
+ formatTimeZone :: CalendarTime -> String
+ formatTimeZone time
+ = case ctTZ time
+ of offset | offset < 0 -> '-':(showTZ $ negate offset)
+ | offset == 0 -> "Z"
+ | otherwise -> '+':(showTZ offset)
+
+ showTZ :: Int -> String
+ showTZ offset
+ = let hour = offset `div` 3600
+ min = (offset - hour * 3600) `div` 60
+ in
+ show2 hour ++ ":" ++ show2 min
+
+ show2 :: Int -> String
+ show2 n | n < 10 = '0':(show n)
+ | otherwise = show n
\ No newline at end of file
projects / Rakka.git / commitdiff