airship 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+225/−42 lines, 7 filesdep +base64-bytestringdep +bytestring-triedep +cryptohashdep ~blaze-builderdep ~mtldep ~transformersnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: base64-bytestring, bytestring-trie, cryptohash, directory, filepath, mime-types, unix
Dependency ranges changed: blaze-builder, mtl, transformers, transformers-base, warp
API changes (from Hackage documentation)
+ Airship.Resource.Static: Cache :: StaticOptions
+ Airship.Resource.Static: FileInfo :: FilePath -> Integer -> UTCTime -> ETag -> FileInfo
+ Airship.Resource.Static: NoCache :: StaticOptions
+ Airship.Resource.Static: _etag :: FileInfo -> ETag
+ Airship.Resource.Static: _lastModified :: FileInfo -> UTCTime
+ Airship.Resource.Static: _path :: FileInfo -> FilePath
+ Airship.Resource.Static: _size :: FileInfo -> Integer
+ Airship.Resource.Static: allFilesAtRoot :: FilePath -> IO [FilePath]
+ Airship.Resource.Static: data FileInfo
+ Airship.Resource.Static: data StaticOptions
+ Airship.Resource.Static: directoryTree :: FilePath -> IO FileTree
+ Airship.Resource.Static: epochToUTCTime :: EpochTime -> UTCTime
+ Airship.Resource.Static: instance Eq FileInfo
+ Airship.Resource.Static: instance Eq StaticOptions
+ Airship.Resource.Static: instance Ord FileInfo
+ Airship.Resource.Static: instance Show FileInfo
+ Airship.Resource.Static: staticResource :: StaticOptions -> FilePath -> IO (Resource s m)
+ Airship.Types: _dispatchPath :: ResponseState s m -> [Text]
+ Airship.Types: dispatchPath :: Handler s m [Text]
+ Airship.Types: instance Ord ETag
- Airship.Types: ResponseState :: s -> ResponseHeaders -> ResponseBody m -> HashMap Text Text -> ResponseState s m
+ Airship.Types: ResponseState :: s -> ResponseHeaders -> ResponseBody m -> HashMap Text Text -> [Text] -> ResponseState s m
- Airship.Types: eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace)
+ Airship.Types: eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace)
- Airship.Types: runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace)
+ Airship.Types: runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace)
Files
- airship.cabal +15/−7
- bin/Main.hs +14/−4
- src/Airship/Internal/Decision.hs +3/−3
- src/Airship/Internal/Helpers.hs +12/−8
- src/Airship/Internal/Route.hs +15/−12
- src/Airship/Resource/Static.hs +153/−0
- src/Airship/Types.hs +13/−8
airship.cabal view
@@ -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
bin/Main.hs view
@@ -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 "<html><head></head><body><h1>404 Not Found</h1></body></html>"+ resource404 = defaultResource { resourceExists = return False+ , contentTypesProvided = return+ [ ( "text/html"+ , return response404+ )+ ]+ } mvar <- newMVar HM.empty let s = State mvar
src/Airship/Internal/Decision.hs view
@@ -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"
src/Airship/Internal/Helpers.hs view
@@ -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)
src/Airship/Internal/Route.hs view
@@ -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
+ src/Airship/Resource/Static.hs view
@@ -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")
src/Airship/Types.hs view
@@ -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)