From 03585f9c5773f6c0b59497f4f563909576c402b5 Mon Sep 17 00:00:00 2001 From: pho Date: Mon, 8 Oct 2007 18:50:34 +0900 Subject: [PATCH] I'm getting tired so I must have a rest. darcs-hash:20071008095034-62b54-823fc7d160814f9431895483cd208b619de09f87.gz --- Rakka.cabal | 2 +- Rakka/Environment.hs | 41 +++++++++++++++- Rakka/Page.hs | 28 ++++++++++- Rakka/Resource.hs | 85 ++++++++++++++++++++++++++++++++ Rakka/Resource/Page.hs | 17 ++++--- Rakka/Resource/Page/Get.hs | 94 ++++++++++++++++++++++++++++++++++++ Rakka/Storage.hs | 19 ++++++-- Rakka/Storage/DefaultPage.hs | 40 +++++++++++---- Rakka/Utils.hs | 38 ++++++++++++++- 9 files changed, 339 insertions(+), 25 deletions(-) create mode 100644 Rakka/Resource.hs create mode 100644 Rakka/Resource/Page/Get.hs diff --git a/Rakka.cabal b/Rakka.cabal index 14087de..9c173bf 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -25,7 +25,7 @@ Extensions: 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 diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index e793d00..881a9e6 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -1,11 +1,21 @@ 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 @@ -26,4 +36,33 @@ setupEnv lsdir portNum 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 diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 607a0a8..2e3ea45 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -2,6 +2,8 @@ module Rakka.Page ( PageName , Page(..) , encodePageName + , decodePageName + , mkPageURI ) where @@ -12,14 +14,20 @@ import Data.Encoding.UTF8 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 以外では無意味 @@ -27,6 +35,7 @@ data Page , pageIsLocked :: Bool , pageIsBoring :: Bool , pageRevision :: Maybe RevNum + , pageLastMod :: CalendarTime , pageSummary :: Maybe String , pageOtherLang :: [(String, PageName)] , pageContent :: LazyByteString @@ -41,3 +50,18 @@ encodePageName = escapeURIString shouldEscape . C8.unpack . encode UTF8 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 diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs new file mode 100644 index 0000000..c79b215 --- /dev/null +++ b/Rakka/Resource.hs @@ -0,0 +1,85 @@ +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 diff --git a/Rakka/Resource/Page.hs b/Rakka/Resource/Page.hs index 8077c4f..c72cf88 100644 --- a/Rakka/Resource/Page.hs +++ b/Rakka/Resource/Page.hs @@ -5,7 +5,10 @@ module Rakka.Resource.Page 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) @@ -17,21 +20,21 @@ fallbackPage env path = 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" diff --git a/Rakka/Resource/Page/Get.hs b/Rakka/Resource/Page/Get.hs new file mode 100644 index 0000000..322e9db --- /dev/null +++ b/Rakka/Resource/Page/Get.hs @@ -0,0 +1,94 @@ +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 + + + + + [text/* の場合] + + -- デフォルトでない場合のみ存在 + lastModified="2000-01-01T00:00:00" /> + + + blah blah... + -- 存在しない場合もある + + + + + + + blah blah... + + + + + [text/* 以外の場合: content 要素の代はりに object 要素] + + -- 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 diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index d830131..7a0d0c2 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -4,12 +4,17 @@ module Rakka.Storage , 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 @@ -24,6 +29,14 @@ getPage sto name = 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 diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 8770ef0..9cdaf45 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -5,12 +5,14 @@ module Rakka.Storage.DefaultPage 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 @@ -37,7 +39,9 @@ loadDefaultPage pageName loadPageFile :: PageName -> FilePath -> IO Page loadPageFile name path - = do [page] <- runX ( constA (name, path) + = do [page] <- runX ( setErrorMsgHandler False fail + >>> + constA (name, path) >>> loadPageFileA ) @@ -47,16 +51,31 @@ loadPageFile name path 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 @@ -90,7 +109,7 @@ parsePage (Just text, _ ) -> L8.pack text (_ , Just binary) -> L8.pack $ B64.decode binary - returnA -< Page { + returnA -< Entity { pageName = name , pageType = mimeType , pageIsTheme = isTheme @@ -98,6 +117,7 @@ parsePage , pageIsLocked = isLocked , pageIsBoring = isBoring , pageRevision = Nothing + , pageLastMod = lastMod , pageSummary = summary , pageOtherLang = otherLang , pageContent = content diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index cb77474..4da609c 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -3,11 +3,14 @@ module Rakka.Utils , maybeA , defaultTo , deleteIfEmpty + , formatW3CDateTime ) where import Control.Arrow import Control.Arrow.ArrowList +import System.Time +import Text.Printf parseYesOrNo :: ArrowChoice a => a String Bool @@ -37,4 +40,37 @@ deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String 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 -- 2.40.0