Rakka/Page.hs

   1 module Rakka.Page
   2     ( PageName
   3     , Page(..)
   4     , LanguageTag
   5     , LanguageName
   6
   7     , encodePageName
   8     , decodePageName
   9
  10     , pageFileName'
  11
  12     , mkPageURI
  13     , mkPageFragmentURI
  14     , mkObjectURI
  15     , mkFragmentURI
  16     , mkAuxiliaryURI
  17     , mkRakkaURI
  18     )
  19     where
  20
  21 import           Data.ByteString.Base (LazyByteString)
  22 import qualified Data.ByteString.Char8 as C8
  23 import           Data.Char
  24 import           Data.Encoding
  25 import           Data.Encoding.UTF8
  26 import           Data.Map (Map)
  27 import           Data.Maybe
  28 import           Network.HTTP.Lucu
  29 import           Network.URI
  30 import           Subversion.Types
  31 import           System.FilePath.Posix
  32 import           System.Time
  33
  34
  35 type PageName = String
  36
  37 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  38 type LanguageName = String -- i.e. "日本語"
  39
  40
  41 data Page
  42     = Redirection {
  43         redirName     :: !PageName
  44       , redirDest     :: !PageName
  45       , redirRevision :: !(Maybe RevNum)
  46       , redirLastMod  :: !CalendarTime
  47       }
  48     | Entity {
  49         pageName      :: !PageName
  50       , pageType      :: !MIMEType
  51       , pageLanguage  :: !(Maybe LanguageTag)
  52       , pageFileName  :: !(Maybe String)
  53       , pageIsTheme   :: !Bool     -- text/css 以外では無意味
  54       , pageIsFeed    :: !Bool     -- text/x-rakka 以外では無意味
  55       , pageIsLocked  :: !Bool
  56       , pageIsBoring  :: !Bool
  57       , pageIsBinary  :: !Bool
  58       , pageRevision  :: !RevNum
  59       , pageLastMod   :: !CalendarTime
  60       , pageSummary   :: !(Maybe String)
  61       , pageOtherLang :: !(Map LanguageTag PageName)
  62       , pageContent   :: !LazyByteString
  63       }
  64
  65
  66 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
  67 encodePageName :: PageName -> FilePath
  68 encodePageName = escapeURIString isSafeChar . C8.unpack . encode UTF8 . fixPageName
  69     where
  70       fixPageName :: PageName -> PageName
  71       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
  72
  73
  74 isSafeChar :: Char -> Bool
  75 isSafeChar c
  76     | c == '/'            = True
  77     | isReserved c        = False
  78     | c > ' ' && c <= '~' = True
  79     | otherwise           = False
  80
  81
  82 -- URI unescape して UTF-8 から decode する。
  83 decodePageName :: FilePath -> PageName
  84 decodePageName = decode UTF8 . C8.pack . unEscapeString
  85
  86
  87 encodeFragment :: String -> String
  88 encodeFragment = escapeURIString isSafeChar . C8.unpack . encode UTF8
  89
  90
  91 pageFileName' :: Page -> String
  92 pageFileName' page = fromMaybe (defaultFileName page) (pageFileName page)
  93
  94
  95 defaultFileName :: Page -> String
  96 defaultFileName page
  97     = let baseName = takeFileName (pageName page)
  98       in
  99         case pageType page of
 100           MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
 101           MIMEType "text" "css"     _ -> baseName <.> "css"
 102           _                           -> baseName
 103
 104
 105 mkPageURI :: URI -> PageName -> URI
 106 mkPageURI baseURI name
 107     = baseURI {
 108         uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 109       }
 110
 111
 112 mkPageFragmentURI :: URI -> PageName -> String -> URI
 113 mkPageFragmentURI baseURI name fragment
 114     = baseURI {
 115         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 116       , uriFragment = ('#' : encodeFragment fragment)
 117       }
 118
 119
 120 mkFragmentURI :: String -> URI
 121 mkFragmentURI fragment
 122     = nullURI {
 123         uriFragment = ('#' : encodeFragment fragment)
 124       }
 125
 126
 127 mkObjectURI :: URI -> PageName -> URI
 128 mkObjectURI baseURI name
 129     = mkAuxiliaryURI baseURI ["object"] name
 130
 131
 132 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 133 mkAuxiliaryURI baseURI basePath name
 134     = baseURI {
 135         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 136       }
 137
 138
 139 mkRakkaURI :: PageName -> URI
 140 mkRakkaURI name = URI {
 141                     uriScheme    = "rakka:"
 142                   , uriAuthority = Nothing
 143                   , uriPath      = encodePageName name
 144                   , uriQuery     = ""
 145                   , uriFragment  = ""
 146                   }