sssp-1.0.0: Aws/SSSP.hs
{-# LANGUAGE OverloadedStrings
, ParallelListComp
, RecordWildCards
, StandaloneDeriving
, PatternGuards
#-}
module Aws.SSSP where
import Control.Applicative
import Control.Arrow ((***))
import Control.Monad
import Data.Char
import Data.Either
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Bytes
import qualified Data.List as List
import Data.Maybe
import Data.Monoid
import Data.Ord
import qualified Data.Set as Set
import Data.Word
import qualified Aws as Aws
import qualified Aws.Core as Aws
import qualified Aws.S3 as Aws
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import Control.Monad.Trans
import Data.Attempt
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as Atto
import qualified Data.Conduit as Conduit
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import qualified Network.Wai as WWW
import qualified Network.HTTP.Conduit as Conduit
import qualified Network.HTTP.Types as HTTP
import qualified Aws.SSSP.WWW as WWW
wai :: Ctx -> WWW.Application
wai ctx@Ctx{..} req@WWW.Request{..} = do
resolved <- task ctx requestMethod (resource req)
maybe (return badTask) id $ do
task <- resolved
Just $ case task of
Retrieve t -> do
maybe (return badTime) id $ do
seconds <- timeParam
Just $ do
sigInfo <- liftIO $ sigData (fromIntegral seconds)
let q = Aws.getObject bucket t
s = Aws.queryToUri (Aws.signQuery q s3 sigInfo)
b = Blaze.fromByteString (s `Bytes.snoc` '\n')
m = "max-age=" ++ show (seconds - 1)
headers = [("Cache-Control", Bytes.pack m)
,("Content-Type", "text/plain")
,("Location", s)]
if direct then WWW.proxied manager (Bytes.unpack s)
else return $ WWW.ResponseBuilder status307 headers b
Listing ts -> do
return $ WWW.ResponseBuilder
HTTP.status200 [("Content-Type", "text/plain")]
(mconcat (plusNL . s3Encode <$> ts))
Remove ts -> do
let deletes = [ Aws.DeleteObject t bucket | t <- ts ]
responses <- mapM (Aws.aws aws s3 manager) deletes
let attempts = [ attempt | Aws.Response _meta attempt <- responses ]
d = [ mappend `uncurry` case a of
Success _ -> ("deleted: ", t)
Failure _ -> ("failed: ", t) | a <- attempts | t <- ts ]
status | all isSuccess attempts = HTTP.status200
| otherwise = HTTP.status500
return $ WWW.ResponseBuilder
status [("Content-Type", "text/plain")]
(Blaze.fromText . Text.unlines $ d)
Write t -> do
let len = join $ listToMaybe
[ fst <$> (listToMaybe . reads . Bytes.unpack) v
| (k, v) <- requestHeaders, k == "Content-Length" ]
maybe (return noLength) id $ do
n <- len
Just . maybe (return badTime) id $ do
seconds <- timeParam
Just $ do
sigInfo <- liftIO $ sigData (fromIntegral seconds)
let q = Aws.putObject bucket t (blazeBody n)
r = WWW.addHeaders q requestHeaders
s = Aws.queryToUri (Aws.signQuery r s3 sigInfo)
b = Blaze.fromByteString (s `Bytes.snoc` '\n')
m = "max-age=" ++ show (defaultSeconds - 1)
headers = [("Cache-Control", Bytes.pack m)
,("Content-Type", "text/plain")
,("Location", s)]
return $ WWW.ResponseBuilder status307 headers b
where
defaultSeconds = 10
status307 = HTTP.Status 307 "Temporary Redirect"
sigData n = Aws.signatureData (Aws.ExpiresIn n) (Aws.credentials aws)
badTask = WWW.ResponseBuilder
HTTP.status400 [("Content-Type", "text/plain")]
(Blaze.fromByteString "Malformed task.\n")
noLength = WWW.ResponseBuilder
HTTP.status400 [("Content-Type", "text/plain")]
(Blaze.fromByteString "No Content-Length header.\n")
badTime = WWW.ResponseBuilder
HTTP.status400 [("Content-Type", "text/plain")]
(Blaze.fromByteString "Give time as t=2..40000000\n")
blazeBody len = Conduit.RequestBodySource len
. Conduit.mapOutput Blaze.fromByteString $ requestBody
timeParam = (maybe defaultSeconds id . listToMaybe)
<$> sequence [ f v | (k, Just v) <- queryString, k == "t" ]
where
f :: ByteString -> Maybe Integer
f = (validate =<<) . (fst <$>) . listToMaybe . reads . Bytes.unpack
validate i = guard (notTooMany i) >> Just i
notTooMany i = i >= 2 && i <= 40000000 -- About 16 months
direct = any ((=="direct") . fst) queryString
task :: Ctx -> HTTP.Method -> Resource -> Conduit.ResourceT IO (Maybe Task)
task ctx method resource = do
urls <- fromAttempt <$> resolve ctx resource
return $ case (method, resource) of
("GET", Singular _) -> Retrieve <$> (listToMaybe =<< urls)
("GET", Plural _) -> Listing <$> urls
("DELETE", _) -> Remove <$> urls
("PUT", Singular _) -> Write <$> (listToMaybe =<< urls)
_ -> Nothing
data Task = Retrieve Text
| Listing [Text]
| Remove [Text]
| Write Text -- (Conduit.RequestBody IO)
deriving (Eq, Ord, Show)
-- | Resources are either singular or plural in character. URLs ending ending
-- in @/@ or containing set wildcards specify plural resources; all other
-- URLs indicate singular resources. A singular resource results in a
-- redirect while a plural resource results in a newline-separated list of
-- URLs (themselves singular in character).
data Resource = Singular [Either Text Wildcard]
| Plural [Either (Either Text Wildcard) SetWildcard]
deriving (Eq, Ord, Show)
data Ctx = Ctx { bucket :: Aws.Bucket
, aws :: Aws.Configuration
, s3 :: Aws.S3Configuration Aws.NormalQuery
, manager :: Conduit.Manager }
instance Show Ctx where
show Ctx{..} = mconcat [ "Ctx { bucket=", show bucket
, ", aws=..., s3=", show s3, " }" ]
data Order = ASCII | SemVer deriving (Eq, Ord, Show)
data Wildcard = Hi Order | Lo Order deriving (Eq, Ord, Show)
data SetWildcard = Include Word Wildcard | Exclude Word Wildcard
deriving (Eq, Ord, Show)
-- | Interpret a request URL as a resource, expanding wildcards as needed. By
-- default, wildcards are expanded with @\@@ as the meta-character (@\@hi@,
-- @\@lo.semver5@) but the meta-character can be changed with a query
-- parameter so we pass the whole request here.
--
-- The meta-character is in leading position in wildcard path components and
-- escapes itself in leading position, in a simple way: leading runs are
-- shortened by one character. Some examples of path components and their
-- interpretation are helpful:
--
-- > hi -> The string "hi".
-- > @hi -> The hi.semver wildcard.
-- > @@hi -> The string "@hi".
-- > @@@hi -> The string "@@hi".
-- > ...and so on...
--
-- Sending @meta=_@ as a query parameter changes the meta-character to an
-- underscore. The meta-character may be any single character; empty or
-- overlong @meta@ parameters are ignored.
resource :: WWW.Request -> Resource
resource WWW.Request{..} = url metaChar pathInfo
where
metaParams = [ b | Just (b, _) <- culled ] :: [Char]
where culled = [ Bytes.uncons v | (k, Just v) <- queryString, k == "meta" ]
metaChar = List.head (metaParams ++ ['@'])
url :: Char -> [Text] -> Resource
url _ [] = Plural []
url meta texts | singular = Singular (lefts components)
| otherwise = Plural components
where
(empty, full) = List.break (/= "") . List.reverse $ texts
empty' = if empty /= [] then [""] else []
components = parse <$> List.reverse (empty' ++ full)
singular = empty == [] && rights components == []
-- Parser is total but just to be on the safe side...
parse t = either (const . Left . Left $ t) id
(Atto.parseOnly (component meta) t)
-- | Parse a single path component.
component :: Char -> Parser (Either (Either Text Wildcard) SetWildcard)
component meta = eitherRotate <$> Atto.eitherP
(Atto.eitherP (setWildcard meta) (wildcard meta) <* Atto.endOfInput)
(plain meta)
where
eitherRotate :: Either (Either SetWildcard Wildcard) Text
-> Either (Either Text Wildcard) SetWildcard
eitherRotate (Left (Right wc)) = Left (Right wc)
eitherRotate (Left (Left set)) = Right set
eitherRotate (Right text) = Left (Left text)
-- | Parse a plain string, shrinking leading runs of the metacharacter by one.
plain :: Char -> Parser Text
plain c = mappend <$> (Text.drop 1 <$> Atto.takeWhile (== c)) <*> Atto.takeText
-- | Match a simple, singular wildcard.
wildcard :: Char -> Parser Wildcard
wildcard meta = Atto.char meta *> Atto.choice matchers
where
matcher (t, w) = Atto.string t *> pure w
matchers = matcher <$> wildcards
-- | Match a wildcard set, ending with a count (if it is inclusive) or an
-- optional count and a final tilde (if it is exclusive).
setWildcard :: Char -> Parser SetWildcard
setWildcard meta = star meta <|> wildcard meta <**> (exclude <|> include)
where
include = Include <$> Atto.decimal
exclude = Exclude <$> Atto.option 1 Atto.decimal <* Atto.char '~'
star :: Char -> Parser SetWildcard
star meta = Atto.char meta *> Atto.char '*'
*> (Exclude 0 . Lo <$> Atto.option SemVer ordering)
where
ordering :: Parser Order
ordering = (Atto.string ".ascii" *> pure ASCII)
<|> (Atto.string ".semver" *> pure SemVer)
-- | Wildcards and their textual representations.
wildcards :: [(Text, Wildcard)]
wildcards = [( "hi.ascii", Hi ASCII) ,( "lo.ascii", Lo ASCII)
,("hi.semver", Hi SemVer) ,("lo.semver", Lo SemVer)
,( "hi", Hi SemVer) ,( "lo", Lo SemVer)]
-- The order of these matters when they are translated to alternative
-- Attoparsec parsers, which is unfortunate and seemingly contrary to the
-- documentation. In lieu of left-factoring, we put the longer prefixes last.
-- | Translate a resource in to a listing of objects. While intermediate S3
-- prefixes (directories) are traversed, the final match is always on keys
-- for objects.
resolve :: Ctx -> Resource -> Conduit.ResourceT IO (Attempt [Text])
resolve Ctx{..} res = case res of
Plural [ ] -> (fst <$>) <$> listing Ctx{..} ""
Plural components -> resolve' "" (simplify <$> components)
Singular components -> resolve' "" (pluralize <$> components)
where
pluralize :: Either Text Wildcard -> Either Text SetWildcard
pluralize = either Left (Right . Include 1)
simplify :: Either (Either Text Wildcard) SetWildcard
-> Either Text SetWildcard
simplify = either pluralize Right
resolve' prefix [ ] = return (Success [prefix])
resolve' prefix (h:t) = case h of
Left "" -> (fst <$>) <$> listing Ctx{..} prefix
Left text -> resolve' (prefix -/- text) t
Right set -> do
attempt <- listing Ctx{..} prefix
case names <$> attempt of
Success texts -> (List.concat <$>) . sequence <$> mapM recurse texts
Failure e -> return (Failure e)
where
recurse text = resolve' text t
names (objects, prefixes) = expand set $ case t of [ ] -> objects
_:_ -> prefixes
listing :: Ctx -> Text -> Conduit.ResourceT IO (Attempt ([Text],[Text]))
listing Ctx{..} prefix =
((concat *** concat) . unzip <$>) <$> listing' Nothing []
where
listing' mark acc = do
Aws.Response _meta attempt <- Aws.aws aws s3 manager gb{Aws.gbMarker=mark}
case attempt of
Success Aws.GetBucketResponse{..} -> do
let (keys, pres) = (Aws.objectKey <$> gbrContents, gbrCommonPrefixes)
if length keys < 1000 -- TODO: Use truncation flag.
then (return . Success . reverse) ((keys, pres):acc)
else listing' (Just (last keys)) ((keys, pres):acc)
Failure e -> return (Failure e)
gb = Aws.GetBucket { Aws.gbBucket = bucket
, Aws.gbPrefix = Just (prefix -/- "")
, Aws.gbDelimiter = Just "/"
, Aws.gbMaxKeys = Just 1000 -- The Amazon maximum.
, Aws.gbMarker = Nothing }
expand :: SetWildcard -> [Text] -> [Text]
expand set texts
| complement && count == 0 = ordered texts -- Special case for "all" wilcard.
| complement = complemented matching
| otherwise = matching
where
matching = (selected . ordered) texts
uniq = Set.fromList texts
complemented = ordered . Set.toList . Set.difference uniq . Set.fromList
(count, wc, complement) = case set of
Include count wc -> (fromIntegral count, wc, False)
Exclude count wc -> (fromIntegral count, wc, True)
(ordered, selected) = case wc of
Hi o -> (order o, List.reverse . List.take count . List.reverse)
Lo o -> (order o, List.take count)
a -/- b | a == "" = mappend a b
| "/" `Text.isSuffixOf` a = mappend a b
| otherwise = mconcat [a, "/", b]
-- | Split a URL into components, placing the balance of slashes in a slash
-- run to the left of the last slash. This is what all the Amazon APIs --
-- including the HTTP interface -- seem to expect, based on experiment.
-- This function exists so that we can split a URL retrieved from S3, by way
-- of list bucket, for example, into pieces for later escaping.
s3Pieces :: Text -> [Text]
s3Pieces text = reverse . uncurry (:) $ List.foldl' f (leading', []) rest'
where
(leading, rest) = List.span (=="") (Text.split (=='/') text)
leading'' = Text.pack [ '/' | _ <- leading ]
(leading', rest') | h:t <- rest = (mappend leading'' h, t)
| otherwise = (leading'', [])
f (piece, pieces) "" = (piece `Text.snoc` '/', pieces)
f (piece, pieces) s = (s, piece:pieces)
-- | Encode an S3 path to a URL, splitting on slashes but preserving slash
-- runs as appropriate.
s3Encode :: Text -> Blaze.Builder
s3Encode = HTTP.encodePathSegmentsRelative . s3Pieces
plusNL :: Blaze.Builder -> Blaze.Builder
plusNL = (`mappend` Blaze.fromChar '\n')
order :: Order -> [Text] -> [Text]
order ASCII = id -- Amazon returns them sorted anyways...
order SemVer = List.sortBy (comparing textSemVer)
textSemVer :: Text -> [Integer]
textSemVer = (fst <$>) . rights . (Text.decimal <$>) . digitalPieces
where
digitalPieces = List.filter (/= "") . Text.split (not . isDigit)