diff --git a/airship.cabal b/airship.cabal --- a/airship.cabal +++ b/airship.cabal @@ -1,7 +1,7 @@ name: airship synopsis: A Webmachine-inspired HTTP library description: A Webmachine-inspired HTTP library -version: 0.1.0.0 +version: 0.2.0.0 license: MIT license-file: LICENSE author: Reid Draper and Patrick Thomson @@ -23,6 +23,7 @@ , Airship.Helpers , Airship.Types , Airship.Resource + , Airship.Resource.Static , Airship.Route other-modules: Airship.Internal.Route @@ -33,23 +34,30 @@ build-depends: attoparsec , base >= 4.7 && < 5 - , blaze-builder == 0.3.* + , base64-bytestring == 1.0.* + , blaze-builder >= 0.3 && < 0.5 , bytestring + , bytestring-trie == 0.2.4.* , case-insensitive + , cryptohash == 0.11.6.* + , directory == 1.2.2.* , either == 4.3.* + , filepath >= 1.3 && < 1.5 , http-date , http-media , http-types >= 0.7 , lifted-base == 0.2.* + , mime-types == 0.1.0.* , monad-control >= 1.0 - , mtl == 2.2.* + , mtl >= 2.2 , network , old-locale , random , text , time - , transformers == 0.4.2.* - , transformers-base == 0.4.3.* + , transformers + , transformers-base + , unix == 2.7.* , unordered-containers , wai == 3.0.* @@ -68,7 +76,7 @@ , time , unordered-containers , wai == 3.0.2.* - , warp == 3.0.5.* + , warp == 3.0.* test-suite unit default-language: Haskell2010 @@ -84,4 +92,4 @@ , tasty-hunit >= 0.9.1 && < 0.10 , transformers == 0.4.2.* , wai == 3.0.* - ghc-options: -Wall -Werror -threaded -O1 -fno-warn-orphans + ghc-options: -Wall -threaded -O1 -fno-warn-orphans diff --git a/bin/Main.hs b/bin/Main.hs --- a/bin/Main.hs +++ b/bin/Main.hs @@ -6,6 +6,7 @@ module Main where import Airship +import Airship.Resource.Static (StaticOptions(..), staticResource) import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText) @@ -106,18 +107,27 @@ s <- getState return (val, accountName, s) -myRoutes :: RoutingSpec State IO () -myRoutes = do +myRoutes :: Resource State IO -> RoutingSpec State IO () +myRoutes static = do root #> resourceWithBody "Just the root resource" "account" var "name" #> accountResource + "static" star #> static main :: IO () main = do + static <- staticResource Cache "assets" let port = 3000 host = "127.0.0.1" settings = setPort port (setHost host defaultSettings) - routes = myRoutes - resource404 = defaultResource + routes = myRoutes static + response404 = escapedResponse "

404 Not Found

" + resource404 = defaultResource { resourceExists = return False + , contentTypesProvided = return + [ ( "text/html" + , return response404 + ) + ] + } mvar <- newMVar HM.empty let s = State mvar diff --git a/src/Airship/Internal/Decision.hs b/src/Airship/Internal/Decision.hs --- a/src/Airship/Internal/Decision.hs +++ b/src/Airship/Internal/Decision.hs @@ -364,7 +364,7 @@ g11 r g08 r@Resource{..} = do - trace "g07" + trace "g08" req <- lift request let reqHeaders = requestHeaders req case lookup hIfMatch reqHeaders of @@ -492,8 +492,8 @@ ifNoneMatch = fromJust (lookup hIfNoneMatch reqHeaders) etags = parseEtagList ifNoneMatch if null etags - then j18 r - else l13 r + then l13 r + else j18 r k07 r@Resource{..} = do trace "k07" diff --git a/src/Airship/Internal/Helpers.hs b/src/Airship/Internal/Helpers.hs --- a/src/Airship/Internal/Helpers.hs +++ b/src/Airship/Internal/Helpers.hs @@ -58,12 +58,16 @@ toWaiResponse :: Response IO -> ByteString -> ByteString -> Wai.Response toWaiResponse Response{..} trace quip = - Wai.responseBuilder _responseStatus headers (fromBody _responseBody) - where fromBody (ResponseBuilder b) = b - fromBody _ = mempty - headers = _responseHeaders ++ - [("Airship-Trace", trace)] ++ - [("Airship-Quip", quip)] + case _responseBody of + (ResponseBuilder b) -> + Wai.responseBuilder _responseStatus headers b + (ResponseFile path part) -> + Wai.responseFile _responseStatus headers path part + (ResponseStream streamer) -> + Wai.responseStream _responseStatus headers streamer + Empty -> + Wai.responseBuilder _responseStatus headers mempty + where headers = _responseHeaders ++ [("Airship-Trace", trace), ("Airship-Quip", quip)] -- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'. resourceToWai :: RoutingSpec s IO () -> Resource s IO -> s -> Wai.Application @@ -71,10 +75,10 @@ let routeMapping = runRouter routes pInfo = Wai.pathInfo req airshipReq = fromWaiRequest req - (resource, params') = route routeMapping pInfo resource404 + (resource, (params', matched)) = route routeMapping pInfo resource404 nowTime <- getCurrentTime quip <- getQuip - (response, trace) <- eitherResponse nowTime params' airshipReq s (flow resource) + (response, trace) <- eitherResponse nowTime params' matched airshipReq s (flow resource) let traceHeaderValue = traceHeader trace respond (toWaiResponse response traceHeaderValue quip) diff --git a/src/Airship/Internal/Route.hs b/src/Airship/Internal/Route.hs --- a/src/Airship/Internal/Route.hs +++ b/src/Airship/Internal/Route.hs @@ -80,27 +80,30 @@ deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource s m)]) -route :: [(Route, a)] -> [Text] -> a -> (a, HashMap Text Text) -route routes pInfo resource404 = foldr' (matchRoute pInfo) (resource404, mempty) routes +route :: [(Route, a)] -> [Text] -> a -> (a, (HashMap Text Text, [Text])) +route routes pInfo resource404 = foldr' (matchRoute pInfo) (resource404, (mempty, mempty)) routes -matchRoute :: [Text] -> (Route, a) -> (a, HashMap Text Text) -> (a, HashMap Text Text) +matchRoute :: [Text] -> (Route, a) -> (a, (HashMap Text Text, [Text])) -> (a, (HashMap Text Text, [Text])) matchRoute paths (rSpec, resource) (previousMatch, previousMap) = case matchesRoute paths rSpec of Nothing -> (previousMatch, previousMap) Just m -> (resource, m) -matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text) -matchesRoute paths spec = matchesRoute' paths (getRoute spec) mempty where +matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text, [Text]) +matchesRoute paths spec = matchesRoute' paths (getRoute spec) (mempty, mempty) False where -- recursion is over, and we never bailed out to return false, so we match - matchesRoute' [] [] acc = Just acc + matchesRoute' [] [] acc _ = Just acc -- there is an extra part of the path left, and we don't have more matching - matchesRoute' (_ph:_ptl) [] _ = Nothing + matchesRoute' (_ph:_ptl) [] _ _ = Nothing -- we match whatever is left, so it doesn't matter what's left in the path - matchesRoute' _ (RestUnbound:_) acc = Just acc + matchesRoute' r (RestUnbound:_) (h, d) _ = Just (h, d ++ r) -- we match a specific string, and it matches this part of the path, -- so recur - matchesRoute' (ph:ptl) (Bound sh:stt) acc + matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) True | ph == sh - = matchesRoute' ptl stt acc - matchesRoute' (ph:ptl) (Var t:stt) acc = matchesRoute' ptl stt (insert t ph acc) - matchesRoute' _ _ _acc = Nothing + = matchesRoute' ptl stt (h, dispatch ++ [ph]) True + matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) False + | ph == sh + = matchesRoute' ptl stt (h, dispatch) False + matchesRoute' (ph:ptl) (Var t:stt) acc _ = matchesRoute' ptl stt (insert t ph (fst acc), snd acc) True + matchesRoute' _ _ _acc _ = Nothing diff --git a/src/Airship/Resource/Static.hs b/src/Airship/Resource/Static.hs new file mode 100644 --- /dev/null +++ b/src/Airship/Resource/Static.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Airship.Resource.Static + ( FileInfo(..) + , StaticOptions(..) + , staticResource + , allFilesAtRoot + , epochToUTCTime + , directoryTree + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif + +import Airship.Headers (addResponseHeader) +import Airship.Types ( ETag(Strong) + , ResponseBody(ResponseFile) + , Handler + , dispatchPath + , halt + ) +import Airship.Resource (Resource(..), defaultResource) + + +import Control.Monad (foldM, when) +import qualified Crypto.Hash.MD5 as MD5 +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as Base64URL +import Data.ByteString.Char8 (pack, split) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Trie as Trie +import Network.HTTP.Media ((//)) +import qualified Network.HTTP.Types as HTTP +import qualified Network.Mime as Mime +import qualified System.Directory as D +import System.FilePath (takeFileName) +import qualified System.Posix.Files as Files +import System.IO (IOMode(ReadMode), withBinaryFile) +import System.Posix.Types (EpochTime) + + +data FileTree = FileTree { tree :: Trie.Trie FileInfo + , root :: T.Text + } + +data FileInfo = FileInfo + { _path :: FilePath + , _size :: Integer + , _lastModified :: UTCTime + , _etag :: ETag + } deriving (Show, Eq, Ord) + +data StaticOptions = Cache | NoCache deriving (Eq) + +epochToUTCTime :: EpochTime -> UTCTime +epochToUTCTime = posixSecondsToUTCTime . realToFrac + +fileETag :: FilePath -> IO ETag +fileETag p = withBinaryFile p ReadMode makeEtag + where makeEtag h = do + let ctx = MD5.init + res <- go ctx h + return (Strong (BS.take 22 (Base64URL.encode (MD5.finalize res)))) + go ctx h = do + bs <- BS.hGetSome h 1024 + if BS.null bs + then return ctx + else return (MD5.update ctx bs) + + +filteredDirectory :: FilePath -> IO [FilePath] +filteredDirectory p = filter (not . (`elem` [".", ".."])) <$> D.getDirectoryContents p + +allFilesAtRoot :: FilePath -> IO [FilePath] +allFilesAtRoot p = filteredDirectory p >>= foldM folder [] + where folder :: [FilePath] -> FilePath -> IO [FilePath] + folder acc f = do + let fullPath = p <> "/" <> f + exists <- D.doesDirectoryExist fullPath + if exists + then do + more <- allFilesAtRoot (p <> "/" <> f) + return (more ++ acc) + else return (fullPath : acc) + +regularFileStatus :: [FilePath] -> IO [(FilePath, Files.FileStatus)] +regularFileStatus fs = filter (Files.isRegularFile . snd) <$> + mapM (\f -> (,) f <$> Files.getFileStatus f) fs + +fileInfos :: [(FilePath, Files.FileStatus, ETag)] -> [(ByteString, FileInfo)] +fileInfos = map (\(p, s, e) -> (pack p, statusToInfo p s e)) + +statusToInfo :: FilePath -> Files.FileStatus -> ETag -> FileInfo +statusToInfo p i e = FileInfo { _path = p + , _size = fromIntegral (Files.fileSize i) + , _lastModified = epochToUTCTime (Files.modificationTime i) + , _etag = e + } + +directoryTree :: FilePath -> IO FileTree +directoryTree f = do + regularFiles <- allFilesAtRoot f >>= regularFileStatus + etags <- mapM (fileETag . fst) regularFiles + let infos = fileInfos (zipWith (\(a,b) c -> (a,b,c)) regularFiles etags) + return (FileTree (Trie.fromList infos) (T.pack f)) + +staticResource :: StaticOptions -> FilePath -> IO (Resource s m) +staticResource options p = staticResource' options <$> directoryTree p + +staticResource' :: StaticOptions -> FileTree -> Resource s m +staticResource' options FileTree{..} = defaultResource + { allowedMethods = return [ HTTP.methodGet, HTTP.methodHead ] + , resourceExists = getFileInfo >> return True + , generateETag = if options == Cache + then Just . _etag <$> getFileInfo + else return Nothing + , lastModified = if options == Cache + then Just . _lastModified <$> getFileInfo + else return Nothing + , contentTypesProvided = do + fInfo <- getFileInfo + when (options == NoCache) addNoCacheHeaders + let response = return (ResponseFile (_path fInfo) Nothing) + fileName = T.pack (takeFileName (_path fInfo)) + fromExtension = Mime.defaultMimeLookup fileName + (a:b:_tl) = split '/' fromExtension + mediaType = a // b + return [ (mediaType, response) + , ("application/octet-stream", response)] + } + where getFileInfo :: Handler s m FileInfo + getFileInfo = do + dispath <- dispatchPath + let key = encodeUtf8 (T.intercalate "/" (root:dispath)) + let res = Trie.lookup key tree + case res of + (Just r) -> return r + Nothing -> halt HTTP.status404 + +addNoCacheHeaders :: Handler s m () +addNoCacheHeaders = do + addResponseHeader (HTTP.hCacheControl, "no-cache, no-store, must-revalidate") + addResponseHeader ("Pragma", "no-cache") + addResponseHeader ("Expires", "0") diff --git a/src/Airship/Types.hs b/src/Airship/Types.hs --- a/src/Airship/Types.hs +++ b/src/Airship/Types.hs @@ -31,6 +31,7 @@ , getResponseHeaders , getResponseBody , params + , dispatchPath , putResponseBody , putResponseBS , halt @@ -121,7 +122,7 @@ data ETag = Strong ByteString | Weak ByteString - deriving (Eq) + deriving (Eq, Ord) instance Show ETag where show = unpack . etagToByteString @@ -152,7 +153,8 @@ data ResponseState s m = ResponseState { stateUser :: s , stateHeaders :: ResponseHeaders , stateBody :: ResponseBody m - , _params :: HashMap Text Text + , _params :: HashMap Text Text + , _dispatchPath :: [Text] } type Trace = [Text] @@ -194,6 +196,9 @@ params :: Handler s m (HashMap Text Text) params = _params <$> get +dispatchPath :: Handler s m [Text] +dispatchPath = _dispatchPath <$> get + -- | Returns the time at which this request began processing. requestTime :: Handler s m UTCTime requestTime = _now <$> ask @@ -267,14 +272,14 @@ both :: Either a a -> a both = either id id -eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace) -eitherResponse reqDate reqParams req s resource = do - (e, trace) <- runWebmachine reqDate reqParams req s resource +eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace) +eitherResponse reqDate reqParams dispatched req s resource = do + (e, trace) <- runWebmachine reqDate reqParams dispatched req s resource return (both e, trace) -runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace) -runWebmachine reqDate reqParams req s w = do - let startingState = ResponseState s [] Empty reqParams +runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace) +runWebmachine reqDate reqParams dispatched req s w = do + let startingState = ResponseState s [] Empty reqParams dispatched requestReader = RequestReader reqDate req (e, _, t) <- runRWST (runEitherT (getWebmachine w)) requestReader startingState return (e, t)