diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c6bd9e1a..2ca147b5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -36,8 +36,8 @@ import Yesod.Internal import Web.Routes.Quasi import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH -import Web.Routes.Site import Language.Haskell.TH.Syntax +import Yesod.WebRoutes import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath (cleanPathFunc) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 4ed310a9..593dd5d7 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -45,13 +45,13 @@ import Data.Maybe (fromMaybe) import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax -import Web.Routes.Site import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 import qualified Codec.Binary.Base64Url import qualified Data.ByteString as S import qualified Data.Serialize +import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/WebRoutes.hs b/Yesod/WebRoutes.hs new file mode 100644 index 00000000..07d08288 --- /dev/null +++ b/Yesod/WebRoutes.hs @@ -0,0 +1,88 @@ +-- | This module should be removed when web-routes incorporates necessary support. +module Yesod.WebRoutes + ( encodePathInfo + , Site (..) + ) where + +import Codec.Binary.UTF8.String (encodeString) +import Data.List (intercalate) +import Network.URI + +encodePathInfo :: [String] -> [(String, String)] -> String +encodePathInfo pieces qs = + let x = map encodeString `o` -- utf-8 encode the data characters in path components (we have not added any delimiters yet) + map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o` -- percent encode the characters + map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o` -- encode . and .. + intercalate "/" -- add in the delimiters + y = showParams qs + in x pieces ++ y + where + -- reverse composition + o :: (a -> b) -> (b -> c) -> a -> c + o = flip (.) + +{-| + +A site groups together the three functions necesary to make an application: + +* A function to convert from the URL type to path segments. + +* A function to convert from path segments to the URL, if possible. + +* A function to return the application for a given URL. + +There are two type parameters for Site: the first is the URL datatype, the +second is the application datatype. The application datatype will depend upon +your server backend. +-} +data Site url a + = Site { + {-| + Return the appropriate application for a given URL. + + The first argument is a function which will give an appropriate + URL (as a String) for a URL datatype. This is usually + constructed by a combination of 'formatPathSegments' and the + prepending of an absolute application root. + + Well behaving applications should use this function to + generating all internal URLs. + -} + handleSite :: (url -> [(String, String)] -> String) -> url -> a + -- | This function must be the inverse of 'parsePathSegments'. + , formatPathSegments :: url -> ([String], [(String, String)]) + -- | This function must be the inverse of 'formatPathSegments'. + , parsePathSegments :: [String] -> Either String url + } + +showParams :: [(String, String)] -> String +showParams [] = "" +showParams z = + '?' : intercalate "&" (map go z) + where + go (x, "") = go' x + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b4c9fb1a..5f50b5dc 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -49,13 +49,12 @@ import qualified Web.ClientSession as CS import Data.Monoid (mempty) import qualified Data.ByteString.UTF8 as BSU import Database.Persist -import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath -import Web.Routes (encodePathInfo) import qualified Data.ByteString.Lazy as L +import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test) diff --git a/yesod.cabal b/yesod.cabal index 51bc22bd..424d8a8b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,7 +30,6 @@ library text >= 0.5 && < 0.8, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, - web-routes >= 0.23 && < 0.24, web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, blaze-builder >= 0.1 && < 0.2, @@ -70,6 +69,7 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static + Yesod.WebRoutes ghc-options: -Wall -Werror executable yesod