Removed Yesod.Application; still have some undefineds

Yesod.hs

@@ -15,7 +15,7 @@ module Yesod
     (
       module Yesod.Request
     , module Yesod.Response
-    , module Yesod.Application
+    , module Yesod.Yesod
     , module Yesod.Definitions
     , module Yesod.Handler
     , module Yesod.Resource
@@ -24,7 +24,7 @@ module Yesod
 
 import Yesod.Request
 import Yesod.Response
-import Yesod.Application
+import Yesod.Yesod
 import Yesod.Definitions
 import Yesod.Handler
 import Yesod.Resource

Yesod/Application.hs

@@ -1,163 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
----------------------------------------------------------
---
--- Module        : Yesod.Application
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Stable
--- Portability   : portable
---
--- Defining the application.
---
----------------------------------------------------------
-module Yesod.Application
-    (
-      toHackApp
-    , RestfulApp (..)
-    ) where
-
-import Web.Encodings
-import Data.Enumerable
-import Control.Monad (when)
-import Data.Object.Html
-
-import qualified Hack
-import Hack.Middleware.CleanPath
-import Hack.Middleware.ClientSession
-import Hack.Middleware.Gzip
-import Hack.Middleware.Jsonp
-import Hack.Middleware.MethodOverride
-
-import Yesod.Request
-import Yesod.Response
-import Yesod.Utils
-import Yesod.Handler
-import Yesod.Definitions
-import Yesod.Constants
-import Yesod.Resource
-import Yesod.Rep
-
-import Data.Convertible.Text
-import Control.Arrow ((***))
-
--- | A data type that can be turned into a Hack application.
-class ResourceName a => RestfulApp a where
-    -- | The encryption key to be used for encrypting client sessions.
-    encryptKey :: a -> IO Word256
-    encryptKey _ = getKey defaultKeyFile
-
-    -- | All of the middlewares to install.
-    hackMiddleware :: a -> [Hack.Middleware]
-    hackMiddleware _ =
-                [ gzip
-                , cleanPath
-                , jsonp
-                , methodOverride
-                ]
-
-    -- | Output error response pages.
-    errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig?
-
-    -- | Whether or not we should check for overlapping resource names.
-    checkOverlaps :: a -> Bool
-    checkOverlaps = const True
-
--- | Given a sample resource name (purely for typing reasons), generating
--- a Hack application.
-toHackApp :: RestfulApp resourceName
-          => resourceName
-          -> IO Hack.Application
-toHackApp a = do
-    when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time?
-    key <- encryptKey a
-    let app' = toHackApplication a getHandler
-        clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way...
-        app = foldr ($) app' $ hackMiddleware a ++ [clientsession']
-    return app
-
-findResourceNames :: ResourceName a
-                  => Resource
-                  -> [(a, [(String, String)])]
-findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate
-
-checkPatternHelper :: ResourceName a
-                   => Resource
-                   -> a
-                   -> Maybe (a, [(String, String)])
-checkPatternHelper r rn =
-    case checkPattern (fromString $ resourcePattern rn) r of
-        Nothing -> Nothing
-        Just pairs -> Just (rn, pairs)
-
-takeJusts :: [Maybe a] -> [a]
-takeJusts [] = []
-takeJusts (Nothing:rest) = takeJusts rest
-takeJusts (Just x:rest) = x : takeJusts rest
-
-toHackApplication :: RestfulApp resourceName
-                  => resourceName
-                  -> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)])
-                  -> Hack.Application
-toHackApplication sampleRN hm env = do
-    -- The following is safe since we run cleanPath as middleware
-    let (Right resource) = splitPath $ Hack.pathInfo env
-    let (handler, urlParams') =
-          case findResourceNames resource of
-            [] -> (notFound, [])
-            ((rn, urlParams''):_) ->
-                let verb = toVerb $ Hack.requestMethod env
-                 in (hm rn verb, urlParams'')
-    let rr = envToRawRequest urlParams' env
-    let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
-        ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept
-    r <-
-        runHandler handler rr sampleRN ctypes' >>=
-        either (applyErrorHandler sampleRN rr ctypes') return
-    responseToHackResponse (rawLanguages rr) r
-
-applyErrorHandler :: (RestfulApp ra, Monad m)
-                  => ra
-                  -> RawRequest
-                  -> [ContentType]
-                  -> (ErrorResult, [Header])
-                  -> m Response
-applyErrorHandler ra rr cts (er, headers) = do
-    let (ct, c) = chooseRep (errorHandler ra rr er) cts
-    return $ Response
-                (getStatus er)
-                (getHeaders er ++ headers)
-                ct
-                c
-
-responseToHackResponse :: [String] -- ^ language list
-                       -> Response -> IO Hack.Response
-responseToHackResponse _FIXMEls (Response sc hs ct c) = do
-    hs' <- mapM toPair hs
-    let hs'' = ("Content-Type", show ct) : hs'
-    let asLBS = unContent c
-    return $ Hack.Response sc hs'' asLBS
-
-envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
-envToRawRequest urlParams' env =
-    let (Right rawPieces) = splitPath $ Hack.pathInfo env
-        gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
-        clength = tryLookup "0" "Content-Length" $ Hack.http env
-        ctype = tryLookup "" "Content-Type" $ Hack.http env
-        (posts, files) = map (convertSuccess *** convertSuccess) ***
-                         map (convertSuccess *** convertFileInfo)
-                       $ parsePost ctype clength
-                       $ Hack.hackInput env
-        rawCookie = tryLookup "" "Cookie" $ Hack.http env
-        cookies' = decodeCookies rawCookie :: [(String, String)]
-        langs = ["en"] -- FIXME
-     in RawRequest rawPieces urlParams' gets' posts cookies' files env langs
-
-convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c
-convertFileInfo (FileInfo a b c) =
-    FileInfo (convertSuccess a) (convertSuccess b) c

Yesod/Definitions.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Definitions
@@ -15,22 +14,22 @@
 ---------------------------------------------------------
 module Yesod.Definitions
     ( Verb (..)
-    , toVerb
     , Resource
     , Approot (..)
     , Language
     ) where
 
 import qualified Hack
+import Data.Convertible.Text
 
 data Verb = Get | Put | Delete | Post
     deriving (Eq, Show)
 
-toVerb :: Hack.RequestMethod -> Verb
+instance ConvertSuccess Hack.RequestMethod Verb where
-toVerb Hack.PUT = Put
+    convertSuccess Hack.PUT = Put
-toVerb Hack.DELETE = Delete
+    convertSuccess Hack.DELETE = Delete
-toVerb Hack.POST = Post
+    convertSuccess Hack.POST = Post
-toVerb _ = Get
+    convertSuccess _ = Get
 
 type Resource = [String]
 

Yesod/Request.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverlappingInstances #-} -- Parameter String
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Request
@@ -56,6 +57,9 @@ import Web.Encodings
 import Data.Time.Calendar (Day, fromGregorian)
 import Data.Char (isDigit)
 import qualified Data.ByteString.Lazy as BL
+import Data.Convertible.Text
+import Hack.Middleware.CleanPath (splitPath)
+import Control.Arrow ((***))
 
 -- $param_overview
 -- In Restful, all of the underlying parameter values are strings. They can
@@ -319,3 +323,19 @@ notBlank rp =
   case paramValue rp of
     "" -> invalidParam (paramType rp) (paramName rp) "Required field"
     s -> return s
+
+instance ConvertSuccess ([(ParamName, ParamValue)], Hack.Env) RawRequest where
+  convertSuccess (urlParams', env) =
+    let (Right rawPieces) = splitPath $ Hack.pathInfo env
+        gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
+        clength = tryLookup "0" "Content-Length" $ Hack.http env
+        ctype = tryLookup "" "Content-Type" $ Hack.http env
+        convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
+        (posts, files) = map (convertSuccess *** convertSuccess) ***
+                         map (convertSuccess *** convertFileInfo)
+                       $ parsePost ctype clength
+                       $ Hack.hackInput env
+        rawCookie = tryLookup "" "Cookie" $ Hack.http env
+        cookies' = decodeCookies rawCookie :: [(String, String)]
+        langs = ["en"] -- FIXME
+     in RawRequest rawPieces urlParams' gets' posts cookies' files env langs

Yesod/Resource.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Resource
@@ -18,9 +20,8 @@
 --
 ---------------------------------------------------------
 module Yesod.Resource
-    ( ResourceName (..)
+    ( ResourcePatternString -- FIXME rename
-    , ResourcePatternString
+    , fromString -- FIXME rename
-    , fromString
     , checkPattern
     , validatePatterns
     , checkResourceName
@@ -32,16 +33,12 @@ module Yesod.Resource
 
 import Data.List.Split (splitOn)
 import Yesod.Definitions
-import Yesod.Handler
 import Data.List (intercalate)
-import Data.Enumerable
 import Data.Char (isDigit)
 
-#if TEST
+import Data.Typeable (Typeable)
-import Yesod.Rep hiding (testSuite)
+import Control.Exception (Exception)
-#else
+import Data.Attempt -- for failure stuff
-import Yesod.Rep
-#endif
 
 #if TEST
 import Control.Monad (replicateM, when)
@@ -83,18 +80,6 @@ fromString' ('*':rest) = Slurp rest
 fromString' ('#':rest) = DynInt rest
 fromString' x = Static x
 
-class (Show a, Enumerable a) => ResourceName a where
-    -- | Get the URL pattern for each different resource name.
-    -- Something like /foo/$bar/baz/ will match the regular expression
-    -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar.
-    --
-    -- Also, /foo/\*bar/ will match /foo/<anything else>, capturing the value
-    -- into the bar urlParam.
-    resourcePattern :: a -> String
-
-    -- | Find the handler for each resource name/verb pattern.
-    getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME
-
 type ResourcePatternString = String
 
 type SMap = [(String, String)]
@@ -150,14 +135,19 @@ overlaps (Static s:x) (DynInt _:y)
     | otherwise = False
 overlaps (Static a:x) (Static b:y) = a == b && overlaps x y
 
-checkResourceName :: (Monad m, ResourceName rn) => rn -> m ()
+data OverlappingPatterns =
-checkResourceName rn = do
+    OverlappingPatterns [(ResourcePattern, ResourcePattern)]
-    let avs@(y:_) = enumerate
+    deriving (Show, Typeable)
-        _ignore = asTypeOf rn y
+instance Exception OverlappingPatterns
-    let patterns = map (fromString . resourcePattern) avs
+
-    case validatePatterns patterns of
+checkResourceName :: MonadFailure OverlappingPatterns f
+                  => [ResourcePatternString]
+                  -> f ()
+checkResourceName patterns' =
+    let patterns = map fromString patterns'
+     in case validatePatterns patterns of
         [] -> return ()
-        x -> fail $ "Overlapping patterns:\n" ++ unlines (map show x)
+        x -> failure $ OverlappingPatterns x
 
 validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)]
 validatePatterns [] = []

Yesod/Yesod.hs

@@ -13,7 +13,11 @@ import Yesod.Definitions
 import Yesod.Resource
 import Yesod.Handler
 
---import Control.Monad (when)
+import Control.Monad (when)
+import Data.Maybe (fromMaybe)
+import Data.Convertible.Text
+import Web.Encodings
+import Control.Arrow ((***))
 
 import qualified Hack
 import Hack.Middleware.CleanPath
@@ -33,15 +37,6 @@ class Yesod a where
     encryptKey :: a -> IO Word256
     encryptKey _ = getKey defaultKeyFile
 
-    -- | All of the middlewares to install.
-    hackMiddleware :: a -> [Hack.Middleware]
-    hackMiddleware _ =
-                [ gzip
-                , cleanPath
-                , jsonp
-                , methodOverride
-                ]
-
     -- | Output error response pages.
     errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair
     errorHandler = defaultErrorHandler
@@ -74,14 +69,72 @@ defaultErrorHandler (InternalError e) cts =
                 [ ("Internal server error", e)
                 ]) cts
 
+-- | For type signature reasons.
+handlers' :: Yesod y => y ->
+             [(ResourcePatternString,
+              [(Verb, [ContentType] -> Handler y ContentPair)])]
+handlers' _ = handlers
+
 toHackApp :: Yesod y => y -> Hack.Application
 toHackApp a env = do
-    -- FIXME when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time?
+    let patterns = map fst $ handlers' a
+    when (checkOverlaps a) $ checkResourceName patterns -- FIXME maybe this should be done compile-time?
     key <- encryptKey a
     let app' = toHackApp' a
-        clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way...
+        middleware =
-        app = foldr ($) app' $ hackMiddleware a ++ [clientsession']
+                [ gzip
+                , cleanPath
+                , jsonp
+                , methodOverride
+                , clientsession [authCookieName] key
+                ]
+        app = foldr ($) app' middleware
     app env
 
 toHackApp' :: Yesod y => y -> Hack.Application
-toHackApp' = undefined -- FIXME
+toHackApp' y env = do
+    let (Right resource) = splitPath $ Hack.pathInfo env
+        types = httpAccept env
+        (handler, urlParams') = fromMaybe (notFound, []) $ do
+            (verbPairs, urlParams'') <- lookupHandlers resource
+            let verb = cs $ Hack.requestMethod env
+            handler'' <- lookup verb verbPairs
+            return (handler'' types, urlParams'')
+        rr = envToRawRequest urlParams' env
+    runHandler' handler rr y
+
+httpAccept :: Hack.Env -> [ContentType]
+httpAccept = undefined
+
+lookupHandlers :: Yesod y
+               => Resource
+               -> Maybe
+                  ( [(Verb, [ContentType] -> Handler y ContentPair)]
+                  , [(ParamName, ParamValue)]
+                  )
+lookupHandlers = undefined
+
+runHandler' :: Yesod y
+            => Handler y ContentPair
+            -> RawRequest
+            -> y
+            -> IO Hack.Response
+runHandler' = undefined
+
+envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
+envToRawRequest urlParams' env =
+    let (Right rawPieces) = splitPath $ Hack.pathInfo env
+        gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
+        clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env
+        ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env
+        (posts, files) = map (cs *** cs) *** map (cs *** convertFileInfo)
+                       $ parsePost ctype clength
+                       $ Hack.hackInput env
+        rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env
+        cookies' = decodeCookies rawCookie :: [(String, String)]
+        langs = ["en"] -- FIXME
+     in RawRequest rawPieces urlParams' gets' posts cookies' files env langs
+
+convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c
+convertFileInfo (FileInfo a b c) =
+    FileInfo (convertSuccess a) (convertSuccess b) c

yesod.cabal

@@ -51,7 +51,6 @@ library
                      Yesod.Utils
                      Yesod.Definitions
                      Yesod.Handler
-                     Yesod.Application
                      Yesod.Resource
                      Yesod.Yesod
                      Data.Object.Html