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
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
deriving (Eq, Ord, Show)
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)
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 == []
parse t = either (const . Left . Left $ t) id
(Atto.parseOnly (component meta) t)
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)
plain :: Char -> Parser Text
plain c = mappend <$> (Text.drop 1 <$> Atto.takeWhile (== c)) <*> Atto.takeText
wildcard :: Char -> Parser Wildcard
wildcard meta = Atto.char meta *> Atto.choice matchers
where
matcher (t, w) = Atto.string t *> pure w
matchers = matcher <$> wildcards
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 :: [(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)]
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
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
, Aws.gbMarker = Nothing }
expand :: SetWildcard -> [Text] -> [Text]
expand set texts
| complement && count == 0 = ordered texts
| 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]
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)
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
order SemVer = List.sortBy (comparing textSemVer)
textSemVer :: Text -> [Integer]
textSemVer = (fst <$>) . rights . (Text.decimal <$>) . digitalPieces
where
digitalPieces = List.filter (/= "") . Text.split (not . isDigit)