X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=9d84cf28df7f0285c2788842773063998c638a5b;hb=45a315230ec341d3f7a9b80f8004148949a5e2e5;hp=1fd54c92f326ad1e84e348b0452c3d0541c780b4;hpb=ddf0b4d7ab2f1e141edbc7ef75d39853c0846f8c;p=Rakka.git

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 1fd54c9..9d84cf2 100644
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -8,10 +8,12 @@ module Rakka.Page
     , decodePageName
 
     , pageFileName'
+    , defaultFileName
 
     , mkPageURI
     , mkPageFragmentURI
     , mkObjectURI
+    , mkFragmentURI
     , mkAuxiliaryURI
     , mkRakkaURI
     )
@@ -64,33 +66,39 @@ data Page
 
 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 encodePageName :: PageName -> FilePath
-encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 . fixPageName
+encodePageName = escapeURIString isSafeChar . C8.unpack . encode UTF8 . fixPageName
     where
-      isSafe :: Char -> Bool
-      isSafe c
-          | c == '/'             = True
-          | isReserved c         = False
-          | c >= ' ' && c <= '~' = True
-          | otherwise            = False
-
       fixPageName :: PageName -> PageName
       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 
 
+isSafeChar :: Char -> Bool
+isSafeChar c
+    | c == '/'            = True
+    | isReserved c        = False
+    | c > ' ' && c <= '~' = True
+    | otherwise           = False
+
+
 -- URI unescape して UTF-8 から decode する。
 decodePageName :: FilePath -> PageName
 decodePageName = decode UTF8 . C8.pack . unEscapeString
 
 
+encodeFragment :: String -> String
+encodeFragment = escapeURIString isSafeChar . C8.unpack . encode UTF8
+
+
 pageFileName' :: Page -> String
-pageFileName' page = fromMaybe (defaultFileName page) (pageFileName page)
+pageFileName' page
+    = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page)
 
 
-defaultFileName :: Page -> String
-defaultFileName page
-    = let baseName = takeFileName (pageName page)
+defaultFileName :: MIMEType -> PageName -> String
+defaultFileName pType pName
+    = let baseName = takeFileName pName
       in 
-        case pageType page of
+        case pType of
           MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
           MIMEType "text" "css"     _ -> baseName <.> "css"
           _                           -> baseName
@@ -107,7 +115,14 @@ mkPageFragmentURI :: URI -> PageName -> String -> URI
 mkPageFragmentURI baseURI name fragment
     = baseURI {
         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
-      , uriFragment = ('#':fragment)
+      , uriFragment = ('#' : encodeFragment fragment)
+      }
+
+
+mkFragmentURI :: String -> URI
+mkFragmentURI fragment
+    = nullURI {
+        uriFragment = ('#' : encodeFragment fragment)
       }