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           Codec.Binary.UTF8.String
  23 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  24 import           Data.Char
  25 import           Data.Map (Map)
  26 import           Data.Maybe
  27 import           Data.Time
  28 import           Network.HTTP.Lucu
  29 import           Network.URI hiding (fragment)
  30 import           Subversion.Types
  31 import           System.FilePath.Posix
  32
  33
  34 type PageName = String
  35
  36 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  37 type LanguageName = String -- i.e. "日本語"
  38
  39
  40 data Page
  41     = Redirection {
  42         redirName     :: !PageName
  43       , redirDest     :: !PageName
  44       , redirRevision :: !(Maybe RevNum)
  45       , redirLastMod  :: !UTCTime
  46       }
  47     | Entity {
  48         pageName      :: !PageName
  49       , pageType      :: !MIMEType
  50       , pageLanguage  :: !(Maybe LanguageTag)
  51       , pageFileName  :: !(Maybe String)
  52       , pageIsTheme   :: !Bool     -- text/css 以外では無意味
  53       , pageIsFeed    :: !Bool     -- text/x-rakka 以外では無意味
  54       , pageIsLocked  :: !Bool
  55       , pageIsBoring  :: !Bool
  56       , pageIsBinary  :: !Bool
  57       , pageRevision  :: !RevNum
  58       , pageLastMod   :: !UTCTime
  59       , pageSummary   :: !(Maybe String)
  60       , pageOtherLang :: !(Map LanguageTag PageName)
  61       , pageContent   :: !Lazy.ByteString
  62       }
  63     deriving (Show, Eq)
  64
  65
  66 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
  67 encodePageName :: PageName -> FilePath
  68 encodePageName = escapeURIString isSafeChar . encodeString . 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 = decodeString . unEscapeString
  85
  86
  87 encodeFragment :: String -> String
  88 encodeFragment = escapeURIString isSafeChar . encodeString
  89
  90
  91 pageFileName' :: Page -> String
  92 pageFileName' page
  93     = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page)
  94
  95
  96 defaultFileName :: MIMEType -> PageName -> String
  97 defaultFileName pType pName
  98     = let baseName = takeFileName pName
  99       in
 100         case pType of
 101           MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
 102           MIMEType "text" "css"     _ -> baseName <.> "css"
 103           _                           -> baseName
 104
 105
 106 mkPageURI :: URI -> PageName -> URI
 107 mkPageURI baseURI name
 108     = baseURI {
 109         uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 110       }
 111
 112
 113 mkPageFragmentURI :: URI -> PageName -> String -> URI
 114 mkPageFragmentURI baseURI name fragment
 115     = baseURI {
 116         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 117       , uriFragment = ('#' : encodeFragment fragment)
 118       }
 119
 120
 121 mkFragmentURI :: String -> URI
 122 mkFragmentURI fragment
 123     = nullURI {
 124         uriFragment = ('#' : encodeFragment fragment)
 125       }
 126
 127
 128 mkObjectURI :: URI -> PageName -> URI
 129 mkObjectURI baseURI name
 130     = mkAuxiliaryURI baseURI ["object"] name
 131
 132
 133 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 134 mkAuxiliaryURI baseURI basePath name
 135     = baseURI {
 136         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 137       }
 138
 139
 140 mkRakkaURI :: PageName -> URI
 141 mkRakkaURI name = URI {
 142                     uriScheme    = "rakka:"
 143                   , uriAuthority = Nothing
 144                   , uriPath      = encodePageName name
 145                   , uriQuery     = ""
 146                   , uriFragment  = ""
 147                   }