diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index d26a1f1..6b69e9a 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -34,7 +34,6 @@ sendfile :: String -> IO (Response String) sendfile filename = do body <- readFile filename return $ response 200 [mkHeader HdrContentType mime] body - where mime = fromMaybe "application/octet-stream" $ chooseMime filename -- | Just serve static files @@ -77,7 +76,6 @@ httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do defaultURLConf :: URLConf defaultURLConf = RawFunction serveStatic --- freePools :: MPool DBConnection -> MPool CacheConnection -> IO () cleanup dbPool cPool hacc herr = do print "Disconnecting from DB and cache" freeAll dbPool disconnect' diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs index 9d8a377..d04d46a 100644 --- a/Framework/Http/Httpd.hs +++ b/Framework/Http/Httpd.hs @@ -60,9 +60,9 @@ This server transfers documents as one parcel, using the content-length header. -} initServer - :: Int -- ^ The port number + :: Int -- ^ The port number -> (Request S -> IO (Response S)) -- ^ The functionality of the Sever - -> IO Server -- ^ A token for the Server + -> IO Server -- ^ A token for the Server initServer = initServerMain (\body -> ([mkHeader HdrContentLength (show $ length body)], body)) @@ -74,10 +74,10 @@ This way you can ship infinitely big documents. It inserts the transfer encoding header for you. -} initServerLazy - :: Int -- ^ Chunk size - -> Int -- ^ The port number + :: Int -- ^ Chunk size + -> Int -- ^ The port number -> (Request S -> IO (Response S)) -- ^ The functionality of the Sever - -> IO Server -- ^ A token for the Server + -> IO Server -- ^ A token for the Server initServerLazy chunkSize = initServerMain (\body -> @@ -116,7 +116,7 @@ initServerMain processBody portNo callOut = do if (mode `elem` [GET,POST,PUT]) && ((proto=="HTTP/1.1")||(proto=="HTTP/1.0")) then case parseURIReference uri of Just uri' -> readHeaders h mode uri' - _ -> do print uri + _ -> do print uri -- FIXME: error handling hClose h else hClose h _ -> hClose h @@ -203,21 +203,6 @@ queryToArguments input = findIx input findVal' index (value,[]) = [(index,unEscapeString value)] findVal' _ _ = [] --- data Request = Request --- { reqMethod :: String --- , reqURI :: URI --- , reqHeaders :: [(String,String)] --- , reqBody :: String --- } --- deriving Show --- --- data Response = Response --- { resCode :: Int --- , resHeaders :: [(String,String)] --- , resBody :: String --- } --- deriving Show - addCache :: Int -> (String,String) addCache n = ("Cache-Control","max-age=" ++ show n) diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index 5c88d76..7a1f3b4 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -4,7 +4,6 @@ module Framework.Http.Middlewares ResponseMiddleware, responseMiddlewares) where --- import Network.Shed.Httpd -- (Request,Response) import Network.HTTP import Framework.Utils diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index a849f1d..7016439 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -19,7 +19,7 @@ url ? pairs = url++(urlencode pairs) -- * Make a Response -- | Generic response response :: Int -- ^ HTTP status code - -> [Header] -- ^ HTTP headers + -> [Header] -- ^ HTTP headers -> String -- ^ Response body -> Response String response code pairs body = Response (int2respCode code) "" (filter notEmptyHeader pairs) body -- FIXME: fix Httpd to allow response message here diff --git a/Framework/Logger.hs b/Framework/Logger.hs index ba4108f..7529908 100644 --- a/Framework/Logger.hs +++ b/Framework/Logger.hs @@ -54,15 +54,7 @@ flushLog chan hndl = do hPutStrLn hndl $ formatMsg item hFlush hndl -untilIO :: IO Bool -> IO a -> IO () -untilIO cond action = do - val <- cond - if val - then return () - else do action - untilIO cond action - -every :: Int -> IO a -> IO b +every :: Int -> IO a -> IO b -- FIXME: code duplication - same as in Pool.hs every ms action = do action threadDelay ms diff --git a/Framework/Models.hs b/Framework/Models.hs index 11e3c78..c17481e 100644 --- a/Framework/Models.hs +++ b/Framework/Models.hs @@ -38,8 +38,7 @@ data Model = Model { mName :: String, -- ^ Model name mTable :: String, -- ^ DB table name mFields :: [ModelField], -- ^ List of model fields (DB table columns) - mCached :: [ModelField] -- ^ Additional fields, which are no in DB --- mChildren :: [(Model,String,String)] -- ^ Children models + mCached :: [ModelFie ld] -- ^ Additional fields, which are no in DB } deriving (Eq,Show) diff --git a/Framework/Urls.hs b/Framework/Urls.hs index b61b1a4..9c6e3bc 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -68,56 +68,57 @@ data URLResult = NoResult -- | Main dispatcher function runURLConf :: StaticConfig -- ^ Static (global) config - -> Request String -- ^ HTTP request + -> Request String -- ^ HTTP request -> String -- ^ URL itself -> URLConf -- ^ Dispatcher configuration -> IO (Response String) -runURLConf ps rq s conf = let murl = parseURIReference s - in case murl of - Nothing -> error "Couldn't parse URL!" - Just url -> do - case runURLConf' conf (urlSplit url) of - NoResult -> return $ noSuchUrl True conf - AC fun -> do - (ac,addSession) <- mkActionConfig ps rq - resp <- case fun ac of - Nothing -> return $ noSuchUrl True conf - Just act -> act - acFree ac - if addSession - then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac) - else return resp - SC fun -> do - resp <- fun ps rq - return resp +runURLConf ps rq s conf = + let murl = parseURIReference s + in case murl of + Nothing -> error "Couldn't parse URL!" + Just url -> do + case runURLConf' conf (urlSplit url) of + NoResult -> return $ noSuchUrl True conf + AC fun -> do + (ac,addSession) <- mkActionConfig ps rq + resp <- case fun ac of + Nothing -> return $ noSuchUrl True conf + Just act -> act + acFree ac + if addSession + then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac) + else return resp + SC fun -> do + resp <- fun ps rq + return resp runURLConf' :: URLConf -> URLParts -> URLResult -- runURLConf' _ [] _ = Nothing -runURLConf' (Prefix p conf) (x:xs) | p==x = runURLConf' conf xs - | otherwise = NoResult -runURLConf' (Prefix p conf) [] = NoResult -runURLConf' (Regexp r conf) (x:xs) = let b = x =~ r :: Bool - in if b - then runURLConf' conf xs - else NoResult -runURLConf' (RegexpFun r f) (x:_) = let part = x =~ r :: String - in if null part - then NoResult - else AC $ \ac -> f ac part -runURLConf' (ManyRegexpFun _ _ _) [] = NoResult -runURLConf' (ManyRegexpFun u [] f) _ = AC $ \ac -> f ac (reverse u) -runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) = let part = x =~ r :: String - in runURLConf' (ManyRegexpFun (part:u) rs f) xs -runURLConf' (Action act) _ = AC $ \ac -> Just (act ac) -runURLConf' (RawFunction f) x = SC $ \ps rq -> f ps rq (urlJoin x) -runURLConf' (Function f) x = AC $ \ac -> f ac (urlJoin x) -runURLConf' (OneOf c d) url = case runURLConf' c url of - NoResult -> runURLConf' d url - x -> x +runURLConf' (Prefix p conf) (x:xs) | p==x = runURLConf' conf xs + | otherwise = NoResult +runURLConf' (Prefix p conf) [] = NoResult +runURLConf' (Regexp r conf) (x:xs) = let b = x =~ r :: Bool + in if b + then runURLConf' conf xs + else NoResult +runURLConf' (RegexpFun r f) (x:_) = let part = x =~ r :: String + in if null part + then NoResult + else AC $ \ac -> f ac part +runURLConf' (ManyRegexpFun _ _ _) [] = NoResult +runURLConf' (ManyRegexpFun u [] f) _ = AC $ \ac -> f ac (reverse u) +runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) = let part = x =~ r :: String + in runURLConf' (ManyRegexpFun (part:u) rs f) xs +runURLConf' (Action act) _ = AC $ \ac -> Just (act ac) +runURLConf' (RawFunction f) x = SC $ \ps rq -> f ps rq (urlJoin x) +runURLConf' (Function f) x = AC $ \ac -> f ac (urlJoin x) +runURLConf' (OneOf c d) url = case runURLConf' c url of + NoResult -> runURLConf' d url + x -> x -- runURLConf' (After c d) (x:xs) = case runURLConf' c [x] of -- NoResult -> runURLConf' d xs -- Just act -> Just (maybe act (act>>) (runURLConf' d xs ac)) -runURLConf' cc xs = error $ unlines ["URLConf error",show cc,show xs] +runURLConf' cc xs = error $ unlines ["URLConf error",show cc,show xs] -- | If current part of URL is equal to given string, then call given function (-->) :: String -> HttpAction -> URLConf diff --git a/Framework/Utils.hs b/Framework/Utils.hs index b383d59..86c5ec9 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -91,6 +91,7 @@ esc = (escapeURIString isAllowedInURI).encodeString ------------------------------------------------------------------------------------------ +-- | Strict version of System.IO.readFile readFile' :: String -> IO String readFile' f = do h <- openFile f ReadMode @@ -122,6 +123,7 @@ lazySlurp fp ix len ------------------------------------------------------------------------------------------ +-- | An opposite to lookup: update value in assosiative list update :: (Eq a) => a -> t -> [(a, t)] -> [(a, t)] update k v [] = [(k,v)] update k v ((x,y):ps) | k==x = (k,v):ps @@ -134,6 +136,6 @@ addDays n = addToClockTime (days n) expirationDate :: IO String expirationDate = do time <- getClockTime - ctime <- toCalendarTime (addDays 14 time) + ctime <- toCalendarTime (addDays 14 time) -- FIXME: get number of days from config! return $ formatCalendarTime defaultTimeLocale "%c" ctime diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs index 8eec1cb..e0d28b9 100644 --- a/Framework/Wrapper.hs +++ b/Framework/Wrapper.hs @@ -49,8 +49,8 @@ acFree ac = do -- * Main wrapper -- | Main API wrapper. Connects to DB etc, then calls given function, then disconnects. -withConfig :: StaticConfig -- ^ Static (global) server configuration - -> Request String -- ^ HTTP request +withConfig :: StaticConfig -- ^ Static (global) server configuration + -> Request String -- ^ HTTP request -> (ActionConfig -> IO (Response String)) -- ^ Worker function -> IO (Response String) withConfig hp rq f = do