Commits

Alex Suraci  committed d990245

use VMT transformer, added Snap object which handles redirection, sending files, and early termination, added request object for handlers
Ignore-this: 5fa47e829c6d56182ebcffef4cafcb25

  • Participants
  • Parent commits 8cd666b

Comments (0)

Files changed (1)

 {-# LANGUAGE QuasiQuotes #-}
+import Data.CIByteString
 import Data.List.Split (wordsBy)
 import Snap.Http.Server
 import Snap.Types
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as M
 import qualified Data.Vector as V
+import qualified Data.Text.Encoding as T
 
-import Atomo.Environment
-import Atomo.Haskell
+import Atomo
 import Atomo.Pretty
+import Atomo.Valuable
 
 
 load :: VM ()
 load = do
     ([$p|Website|] =::) =<< eval [$e|Object clone do: { routes = [] }|]
+    ([$p|Snap|] =::) =<< eval [$e|Object clone|]
 
-    env <- lift get
+    [$p|(s: Block) snap|] =::: [$e|
+        { cc |
+          Snap clone join:
+            { finish = cc
+              join: s
+            }
+        } call/cc
+    |]
+
+    [$p|(s: Snap) redirect-to: (url: String)|] =::: [$e|
+        s finish yield: @(redirect-to: url)
+    |]
+
+    [$p|(s: Snap) send-file: (path: String)|] =::: [$e|
+        s finish yield: @(send-file: path)
+    |]
+
+    [$p|(s: Snap) finish: (body: String)|] =::: [$e|
+        s finish yield: body
+    |]
+
+    env <- get
 
     [$p|(w: Website) start-on: (port: Integer)|] =: do
         w <- here "w"
                 (toBS "localhost")
                 Nothing
                 Nothing
-                (handle env w)
+                (execVM (handle w) env)
 
         return (particle "ok")
 
-handle :: Env -> Value -> Snap ()
-handle e w = do
-    routes <- liftIO . flip runWith e $ do
-        rs <- dispatch (single "routes" w) >>= toList
 
-        fmap haskell $ forM rs $ \a -> do
-            path <- fmap fromString (dispatch (single "from" a))
-            handler <- dispatch (single "to" a)
-            return (toBS path, callHandler path e w handler)
+execVM :: VMT () Snap () -> Env -> Snap ()
+execVM x e = runWith x e >>= either errorResponse return
 
-    case routes of
-        Right rs -> route (fromHaskell' "[(ByteString, Snap a)]" rs)
-        Left e -> writeBS (toBS ("500: Internal Server Error\n\n" ++ show (pretty e)))
+errorResponse :: AtomoError -> Snap ()
+errorResponse e = do
+    modifyResponse $ setResponseStatus 500 (toBS "Internal Server Error")
+    writeBS . toBS . concat $
+        [ "<html>"
+        , "<h1>Error!</h1>"
+        , "<pre>" ++ show (pretty e) ++ "</pre>"
+        , "</html>"
+        ]
 
+handle :: Value -> VMT r Snap ()
+handle w = do
+    e <- get
+    rs <- vmIO (dispatch (single "routes" w)) >>= toList
 
-callHandler :: String -> Env -> Value -> Value -> Snap ()
-callHandler p e w h = do
-    ps <- fmap rqParams getRequest
-    let params = ordered (map tail . filter ((== ':') . head) $ wordsBy (== '/') p) ps
+    routes <- forM rs $ \a -> do
+        path <- liftM fromString (vmIO $ dispatch (single "from" a))
+        handler <- vmIO $ dispatch (single "to" a)
+        return (toBS path, execVM (callHandler path handler w) e)
 
-    r <- liftIO $ flip runWith e $ do
-        args <- list (w : map string params)
-        dispatch (keyword ["call"] [h, args])
+    lift $ route routes
+
+
+callHandler :: String -> Value -> Value -> VMT r Snap ()
+callHandler p h w = do
+    req <- lift getRequest
+    body <- lift $ fmap fromLBS getRequestBody
+
+    w' <- vmIO $ dispatch (single "clone" w)
+
+    reqv <- vmIO (toValue req)
+    vmIO $ do
+        define (psingle "body" (PMatch reqv)) (Primitive Nothing (string body))
+
+        define (psingle "request" (PMatch w')) (Primitive Nothing reqv)
+
+    args <- list (w' : map string (params req))
+    r <- vmIO $ dispatch (keyword ["call"] [h, args])
 
     case r of
-        Right (String t) -> writeText t
-        Left e -> writeBS (toBS ("500: Internal Server Error\n\n" ++ show (pretty e)))
+        Particle (PMKeyword ["redirect-to"] [Nothing, Just s]) ->
+            lift . redirect . toBS . fromString $ s
+
+        Particle (PMKeyword ["send-file"] [Nothing, Just s]) ->
+            lift . sendFile . fromString $ s
+
+        String t ->
+            lift (writeText t)
   where
+    urlParams = map tail . filter ((== ':') . head) $ wordsBy (== '/') p
+
+    params = ordered urlParams . rqParams
+
     ordered [] _ = []
     ordered (n:ns) ps =
         case M.lookup (toBS n) ps of
 
 fromBS :: BS.ByteString -> String
 fromBS = map (toEnum . fromIntegral) . BS.unpack
+
+fromLBS :: LBS.ByteString -> String
+fromLBS = map (toEnum . fromIntegral) . LBS.unpack
+
+
+instance Valuable Request where
+    toValue r = do
+        eval [$e|r = Object clone|]
+
+        [$p|r server-name|] =:: string (fromBS $ rqServerName r)
+        [$p|r server-port|] =:: Integer (fromIntegral $ rqServerPort r)
+
+        [$p|r remote-address|] =:: string (fromBS $ rqRemoteAddr r)
+        [$p|r remote-port|] =:: Integer (fromIntegral $ rqRemotePort r)
+
+        [$p|r local-address|] =:: string (fromBS $ rqLocalAddr r)
+        [$p|r local-hostname|] =:: string (fromBS $ rqLocalHostname r)
+
+        ([$p|r secure?|] =::) =<< bool (rqIsSecure r)
+
+        headers <- list =<< forM (M.toList (headers r)) (\(n, vs) ->
+            dispatch $
+                keyword ["->"]
+                    [ String (T.decodeUtf8 (ciToLower n))
+                    , String (T.decodeUtf8 (last vs))
+                    ])
+
+        [$p|r headers|] =:: headers
+
+        [$p|r content-length|] =::
+            case rqContentLength r of
+                Nothing -> particle "none"
+                Just l -> keyParticleN ["ok"] [Integer (fromIntegral l)]
+
+        [$p|r method|] =:: method (rqMethod r)
+
+        let (v1, v2) = rqVersion r
+        ([$p|r version|] =::) =<< list
+            [ Integer (fromIntegral v1)
+            , Integer (fromIntegral v2)
+            ]
+
+        ([$p|r cookies|] =::) =<< toValue (rqCookies r)
+
+        [$p|r path-info|] =:: string (fromBS $ rqPathInfo r)
+        [$p|r context-path|] =:: string (fromBS $ rqContextPath r)
+        [$p|r uri|] =:: string (fromBS $ rqURI r)
+        [$p|r query-string|] =:: string (fromBS $ rqQueryString r)
+
+        params <- list =<< forM (M.toList (rqParams r)) (\(n, vs) ->
+            dispatch $
+                keyword ["->"]
+                    [ String (T.decodeUtf8 n)
+                    , String (T.decodeUtf8 (last vs))
+                    ])
+
+        [$p|r parameters|] =:: params
+
+        here "r"
+      where
+        method GET = particle "get"
+        method HEAD = particle "head"
+        method POST = particle "post"
+        method PUT = particle "put"
+        method DELETE = particle "delete"
+        method TRACE = particle "trace"
+        method OPTIONS = particle "options"
+        method CONNECT = particle "connect"
+
+    fromValue _ = undefined
+
+
+instance Valuable Cookie where
+    toValue c = do
+        eval [$e|c = Object clone|]
+
+        [$p|c name|] =:: string (fromBS $ cookieName c)
+        [$p|c value|] =:: string (fromBS $ cookieValue c)
+
+        {-[$p|c expires|] =:: -- TODO-}
+
+        [$p|c domain|] =::
+            case cookieDomain c of
+                Nothing -> particle "none"
+                Just d -> keyParticleN ["ok"] [string (fromBS d)]
+
+        [$p|c path|] =::
+            case cookiePath c of
+                Nothing -> particle "none"
+                Just p -> keyParticleN ["ok"] [string (fromBS p)]
+
+        here "c"
+
+    fromValue _ = undefined