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
  64
  65 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
  66 encodePageName :: PageName -> FilePath
  67 encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
  68     where
  69       fixPageName :: PageName -> PageName
  70       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
  71
  72
  73 isSafeChar :: Char -> Bool
  74 isSafeChar c
  75     | c == '/'            = True
  76     | isReserved c        = False
  77     | c > ' ' && c <= '~' = True
  78     | otherwise           = False
  79
  80
  81 -- URI unescape して UTF-8 から decode する。
  82 decodePageName :: FilePath -> PageName
  83 decodePageName = decodeString . unEscapeString
  84
  85
  86 encodeFragment :: String -> String
  87 encodeFragment = escapeURIString isSafeChar . encodeString
  88
  89
  90 pageFileName' :: Page -> String
  91 pageFileName' page
  92     = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page)
  93
  94
  95 defaultFileName :: MIMEType -> PageName -> String
  96 defaultFileName pType pName
  97     = let baseName = takeFileName pName
  98       in
  99         case pType 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                   }