Rakka/Page.hs

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