import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
+import Control.Monad.Trans
import Data.Char
import Data.Maybe
import Network.HTTP.Lucu
import Rakka.SystemConfig
import Rakka.Wiki.Engine
import System.FilePath
+import Text.XML.HXT.Arrow.Namespace
+import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
Nothing
-> handlePageNotFound env -< name
- Just redir@(Redirection _ _ _ _)
+ Just redir@(Redirection _ _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
HTTP/1.1 302 Found
- Location: http://example.org/Destination?from=Source
+ Location: http://example.org/Destination.html#Redirect:Source
-}
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
= proc redir
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
- returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
+ -> returnA -< do mType <- getEntityType
+ case mType of
+ MIMEType "application" "xhtml+xml" _
+ -> do BaseURI baseURI <- getSysConf (envSysConf env)
+ let uri = mkPageFragmentURI
+ baseURI
+ (redirDest redir)
+ ("Redirect:" ++ redirName redir)
+ redirect Found uri
+
+ MIMEType "text" "xml" _
+ -> do setContentType mType
+ [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA redir
+ >>>
+ xmlizePage
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output resultStr
+
+ _ -> fail ("internal error: getEntityType returned " ++ show mType)
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
-- てゐる可能性があるので、ETag も
-- Last-Modified も返す事が出來ない。
- case pageType page of
+ case entityType page of
MIMEType "text" "x-rakka" _
-> return ()
- _ -> case pageRevision page of
- 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) (pageLastMod page)
+ _ -> case entityRevision page of
+ 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
outputXmlPage tree (entityToXHTML env)
+= sattr "type" "text/javascript"
+= attr "src" (arr id >>> mkText)
)
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+ )
)
+= ( eelem "body"
+= ( eelem "div"
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< page
+= sattr "type" "text/javascript"
+= attr "src" (arr id >>> mkText)
)
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+ )
)
+= ( eelem "body"
+= ( eelem "div"
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< pageNotFound
handlePut :: Environment -> PageName -> Resource ()
-handlePut _env _name
- = do xml <- input defaultLimit
- setContentType $ read "text/xml"
- output xml
+handlePut env name
+ = runXmlA env "rakka-page-1.0.rng" $ proc tree
+ -> do page <- parseXmlizedPage -< (name, tree)
+ status <- putPageA (envStorage env) -< page
+ returnA -< setStatus status