packages feed

hw-uri (empty) → 0.0.0.1

raw patch · 18 files changed

+711/−0 lines, 18 filesdep +amazonkadep +amazonka-coredep +amazonka-s3setup-changed

Dependencies added: amazonka, amazonka-core, amazonka-s3, antiope-core, antiope-s3, base, bytestring, directory, exceptions, filepath, hedgehog, hspec, http-client, http-types, hw-hspec-hedgehog, hw-uri, lens, mtl, resourcet, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hw-uri++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, John Ky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of John Ky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# s3-uri+[![master](https://circleci.com/gh/haskell-works/h3-uri/tree/master.svg?style=svg)](https://circleci.com/gh/haskell-works/h3-uri/tree/master)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hw-uri.cabal view
@@ -0,0 +1,98 @@+cabal-version:          2.2++name:                   hw-uri+version:                0.0.0.1+synopsis:               CI Assistant for Haskell projects+description:            CI Assistant for Haskell projects.  Implements package caching.+homepage:               https://github.com/haskell-works/hw-uri+license:                BSD-3-Clause+license-file:           LICENSE+author:                 John Ky+maintainer:             newhoggy@gmail.com+copyright:              John Ky 2019+category:               Development+extra-source-files:     CHANGELOG.md, README.md++source-repository head+  type: git+  location: https://github.com/haskell-works/hw-uri++common base                           { build-depends: base                           >= 4.7        && < 5      }++common amazonka                       { build-depends: amazonka                       >= 1.6.1      && < 1.7    }+common amazonka-core                  { build-depends: amazonka-core                  >= 1.6.1      && < 1.7    }+common amazonka-s3                    { build-depends: amazonka-s3                    >= 1.6.1      && < 1.7    }+common antiope-core                   { build-depends: antiope-core                   >= 7.0.1      && < 8      }+common antiope-s3                     { build-depends: antiope-s3                     >= 7.0.1      && < 8      }+common bytestring                     { build-depends: bytestring                     >= 0.10.8.2   && < 0.11   }+common directory                      { build-depends: directory                      >= 1.3.3.0    && < 1.4    }+common exceptions                     { build-depends: exceptions                     >= 0.10.1     && < 0.11   }+common filepath                       { build-depends: filepath                       >= 1.3        && < 1.5    }+common hedgehog                       { build-depends: hedgehog                       >= 0.5        && < 0.7    }+common hspec                          { build-depends: hspec                          >= 2.4        && < 3      }+common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.7    }+common http-types                     { build-depends: http-types                     >= 0.12.3     && < 0.13   }+common hw-hspec-hedgehog              { build-depends: hw-hspec-hedgehog              >= 0.1.0.4    && < 0.2    }+common lens                           { build-depends: lens                           >= 4.17       && < 5      }+common mtl                            { build-depends: mtl                            >= 2.2.2      && < 2.3    }+common resourcet                      { build-depends: resourcet                      >= 1.2.2      && < 1.3    }+common text                           { build-depends: text                           >= 1.2.3.1    && < 1.3    }++common config+  default-language:     Haskell2010+  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates++library+  import:   base, config+          , amazonka+          , amazonka-core+          , amazonka-s3+          , antiope-core+          , antiope-s3+          , bytestring+          , directory+          , exceptions+          , filepath+          , http-client+          , http-types+          , lens+          , mtl+          , resourcet+          , text+  other-modules:        Paths_hw_uri+  autogen-modules:      Paths_hw_uri+  hs-source-dirs:       src+  exposed-modules:+    HaskellWorks.Data.Uri.AWS.Env+    HaskellWorks.Data.Uri.IO.Console+    HaskellWorks.Data.Uri.IO.Error+    HaskellWorks.Data.Uri.IO.File+    HaskellWorks.Data.Uri.IO.Lazy+    HaskellWorks.Data.Uri.IO.Static+    HaskellWorks.Data.Uri.Location+    HaskellWorks.Data.Uri.Show+    HaskellWorks.Data.Uri.Text+    HaskellWorks.Data.Uri.UriError++test-suite hw-uri-test+  import:   base, config+          , antiope-core+          , antiope-s3+          , bytestring+          , filepath+          , hedgehog+          , hspec+          , http-types+          , hw-hspec-hedgehog+          , lens+          , text++  type:                 exitcode-stdio-1.0+  main-is:              Spec.hs+  build-depends:        hw-uri+  hs-source-dirs:       test+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  build-tools:          hspec-discover+  other-modules:+    HaskellWorks.Data.Uri.AwsSpec+    HaskellWorks.Data.Uri.LocationSpec
+ src/HaskellWorks/Data/Uri/AWS/Env.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.AWS.Env+  ( awsLogger+  ) where++import Antiope.Env                (LogLevel (..))+import Control.Concurrent         (myThreadId)+import Control.Monad+import Data.Semigroup             ((<>))+import HaskellWorks.Data.Uri.Show++import qualified Data.ByteString.Lazy             as LBS+import qualified Data.ByteString.Lazy.Char8       as LC8+import qualified Data.Text.Encoding               as T+import qualified HaskellWorks.Data.Uri.IO.Console as CIO+import qualified System.IO                        as IO++awsLogger :: Maybe LogLevel -> LogLevel -> LC8.ByteString -> IO ()+awsLogger maybeConfigLogLevel msgLogLevel message =+  forM_ maybeConfigLogLevel $ \configLogLevel ->+    when (msgLogLevel <= configLogLevel) $ do+      threadId <- myThreadId+      CIO.hPutStrLn IO.stderr $ "[" <> tshow msgLogLevel <> "] [tid: " <> tshow threadId <> "]"  <> text+  where text = T.decodeUtf8 $ LBS.toStrict message
+ src/HaskellWorks/Data/Uri/IO/Console.hs view
@@ -0,0 +1,35 @@+module HaskellWorks.Data.Uri.IO.Console+  ( putStrLn+  , print+  , hPutStrLn+  , hPrint+  ) where++import Control.Exception      (bracket_)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text              (Text)+import Prelude                (IO, Show (..), ($), (.))++import qualified Control.Concurrent.QSem as IO+import qualified Data.Text.IO            as T+import qualified System.IO               as IO+import qualified System.IO.Unsafe        as IO++sem :: IO.QSem+sem = IO.unsafePerformIO $ IO.newQSem 1+{-# NOINLINE sem #-}++consoleBracket :: IO a -> IO a+consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)++putStrLn :: MonadIO m => Text -> m ()+putStrLn = liftIO . consoleBracket . T.putStrLn++print :: (MonadIO m, Show a) => a -> m ()+print = liftIO . consoleBracket . IO.print++hPutStrLn :: MonadIO m => IO.Handle -> Text -> m ()+hPutStrLn h = liftIO . consoleBracket . T.hPutStrLn h++hPrint :: (MonadIO m, Show a) => IO.Handle -> a -> m ()+hPrint h = liftIO . consoleBracket . IO.hPrint h
+ src/HaskellWorks/Data/Uri/IO/Error.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.IO.Error+  ( exceptFatal+  , exceptWarn+  , maybeToExcept+  , maybeToExceptM+  ) where++import Control.Monad.Except+import Data.Semigroup                 ((<>))+import HaskellWorks.Data.Uri.UriError++import qualified HaskellWorks.Data.Uri.IO.Console as CIO+import qualified System.Exit                      as IO+import qualified System.IO                        as IO++exceptFatal :: MonadIO m => ExceptT UriError m a -> ExceptT UriError m a+exceptFatal f = catchError f handler+  where handler e = do+          liftIO . CIO.hPutStrLn IO.stderr $ "Fatal Error: " <> displayUriError e+          void $ liftIO IO.exitFailure+          throwError e++exceptWarn :: MonadIO m => ExceptT UriError m a -> ExceptT UriError m a+exceptWarn f = catchError f handler+  where handler e = do+          liftIO . CIO.hPutStrLn IO.stderr $ "Warning: " <> displayUriError e+          throwError e++maybeToExcept :: Monad m => UriError -> Maybe a -> ExceptT UriError m a+maybeToExcept message = maybe (throwError message) pure++maybeToExceptM :: Monad m => UriError -> m (Maybe a) -> ExceptT UriError m a+maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)
+ src/HaskellWorks/Data/Uri/IO/File.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.IO.File+  ( listMaybeDirectory+  ) where++import Control.Monad.Except++import qualified System.Directory as IO++listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath]+listMaybeDirectory filepath = do+  exists <- liftIO $ IO.doesDirectoryExist filepath+  if exists+    then liftIO $ IO.listDirectory filepath+    else return []
+ src/HaskellWorks/Data/Uri/IO/Lazy.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.Uri.IO.Lazy+  ( readResource+  , readFirstAvailableResource+  , resourceExists+  , firstExistingResource+  , headS3Uri+  , writeResource+  , createLocalDirectoryIfMissing+  , linkOrCopyResource+  , readHttpUri+  , removePathRecursive+  ) where++import Antiope.Core+import Control.Lens+import Control.Monad                  (void)+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.Trans.Resource+import Data.Either                    (isRight)+import Data.Semigroup                 ((<>))+import Data.Text                      (Text)+import HaskellWorks.Data.Uri.Location (Location (..))+import HaskellWorks.Data.Uri.Show+import HaskellWorks.Data.Uri.UriError++import qualified Antiope.S3.Lazy                  as AWS+import qualified Antiope.S3.Types                 as AWS+import qualified Control.Concurrent               as IO+import qualified Data.ByteString.Lazy             as LBS+import qualified Data.Text                        as T+import qualified HaskellWorks.Data.Uri.IO.Console as CIO+import qualified Network.AWS                      as AWS+import qualified Network.AWS.S3.CopyObject        as AWS+import qualified Network.AWS.S3.HeadObject        as AWS+import qualified Network.AWS.S3.PutObject         as AWS+import qualified Network.HTTP.Client              as HTTP+import qualified Network.HTTP.Types               as HTTP+import qualified System.Directory                 as IO+import qualified System.FilePath.Posix            as FP+import qualified System.IO                        as IO+import qualified System.IO.Error                  as IO++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++handleAwsError :: MonadCatch m => m a -> m (Either UriError a)+handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) ->+  case e of+    (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 404 _) _ _ _ _)) -> return (Left (AwsUriError s))+    (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsUriError s))+    _                                                                      -> throwM e++handleHttpError :: (MonadCatch m, MonadIO m) => m a -> m (Either UriError a)+handleHttpError f = catch (Right <$> f) $ \(e :: HTTP.HttpException) ->+  case e of+    (HTTP.HttpExceptionRequest _ e') -> case e' of+      HTTP.StatusCodeException resp _ -> return (Left (HttpUriError (resp & HTTP.responseStatus)))+      _                               -> return (Left (GenericUriError (tshow e')))+    _                                 -> throwM e++getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either UriError LBS.ByteString)+getS3Uri envAws (AWS.S3Uri b k) = handleAwsError $ runAws envAws $ AWS.unsafeDownload b k++readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either UriError LBS.ByteString)+readResource envAws = \case+  S3 s3Uri        -> getS3Uri envAws s3Uri+  Local path      -> liftIO $ do+    fileExists <- IO.doesFileExist path+    if fileExists+      then Right <$> LBS.readFile path+      else pure (Left NotFound)+  HttpUri httpUri -> liftIO $ readHttpUri httpUri++readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either UriError (LBS.ByteString, Location))+readFirstAvailableResource _ [] = return (Left (GenericUriError "No resources specified in read"))+readFirstAvailableResource envAws (a:as) = do+  result <- readResource envAws a+  case result of+    Right lbs -> return $ Right (lbs, a)+    Left e -> if null as+      then return $ Left e+      else readFirstAvailableResource envAws as++safePathIsSymbolLink :: FilePath -> IO Bool+safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler+  where handler :: IOError -> IO Bool+        handler e = if IO.isDoesNotExistError e+          then return False+          else return True++resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool+resourceExists envAws = \case+  S3 s3Uri        -> isRight <$> runResourceT (headS3Uri envAws s3Uri)+  HttpUri httpUri -> isRight <$> headHttpUri httpUri+  Local path  -> do+    fileExists <- liftIO $ IO.doesFileExist path+    if fileExists+      then return True+      else do+        symbolicLinkExists <- liftIO $ safePathIsSymbolLink path+        if symbolicLinkExists+          then do+            target <- liftIO $ IO.getSymbolicLinkTarget path+            resourceExists envAws (Local target)+          else return False++firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)+firstExistingResource _ [] = return Nothing+firstExistingResource envAws (a:as) = do+  exists <- resourceExists envAws a+  if exists+    then return (Just a)+    else firstExistingResource envAws as++headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either UriError AWS.HeadObjectResponse)+headS3Uri envAws (AWS.S3Uri b k) = handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k++uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either UriError ())+uploadToS3 envAws (AWS.S3Uri b k) lbs = do+  let req = AWS.toBody lbs+  let po  = AWS.putObject b k req+  handleAwsError $ void $ runResAws envAws $ AWS.send po++writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> ExceptT UriError m ()+writeResource envAws loc lbs = ExceptT $ case loc of+  S3 s3Uri   -> uploadToS3 envAws s3Uri lbs+  Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())+  HttpUri _  -> return (Left (GenericUriError "HTTP PUT method not supported"))++createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m ()+createLocalDirectoryIfMissing = \case+  S3 _        -> return ()+  Local path  -> liftIO $ IO.createDirectoryIfMissing True path+  HttpUri _   -> return ()++copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT UriError m ()+copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do+  responseResult <- runResourceT $+    handleAwsError $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)+  case responseResult of+    Right response -> do+      let responseCode = response ^. AWS.corsResponseStatus+      if 200 <= responseCode && responseCode < 300+        then return (Right ())+        else do+          liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response+          return (Left RetriesFailedUriError)+    Left msg -> return (Left msg)++retry :: (Show e, MonadIO m) => Int -> ExceptT e m () -> ExceptT e m ()+retry = retryWhen (const True)++retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()+retryWhen p n f = catchError f $ \exception -> if n > 0+  then do+    liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)"+    liftIO $ IO.threadDelay 1000000+    if (p exception )+      then retry (n - 1) f+      else throwError exception+  else throwError exception++retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()+retryUnless p = retryWhen (not . p)++linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT UriError m ()+linkOrCopyResource envAws source target = case source of+  S3 sourceS3Uri -> case target of+    S3 targetS3Uri -> retryUnless ((== Just 301) . uriErrorStatus) 3 (copyS3Uri envAws sourceS3Uri targetS3Uri)+    Local _        -> throwError "Can't copy between different file backends"+    HttpUri _      -> throwError "Link and copy unsupported for http backend"+  Local sourcePath -> case target of+    S3 _             -> throwError "Can't copy between different file backends"+    Local targetPath -> do+      liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath)+      targetPathExists <- liftIO $ IO.doesFileExist targetPath+      unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath+    HttpUri _      -> throwError "Link and copy unsupported for http backend"+  HttpUri _ -> throwError "HTTP PUT method not supported"++readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either UriError LBS.ByteString)+readHttpUri httpUri = handleHttpError $ do+  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> httpUri))+  response <- liftIO $ HTTP.httpLbs request manager++  return $ HTTP.responseBody response++headHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either UriError LBS.ByteString)+headHttpUri httpUri = handleHttpError $ do+  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> httpUri))+  response <- liftIO $ HTTP.httpLbs request manager++  return $ HTTP.responseBody response++removePathRecursive :: (MonadIO m, MonadCatch m) => FilePath -> m (Either UriError ())+removePathRecursive pkgStorePath = catch action handler+  where action :: MonadIO m => m (Either UriError ())+        action = Right <$> liftIO (IO.removeDirectoryRecursive pkgStorePath)+        handler :: MonadIO m => IOError -> m (Either UriError ())+        handler e = do+          CIO.hPutStrLn IO.stderr $ "Warning: Caught " <> tshow e+          return (Left (GenericUriError (tshow e)))
+ src/HaskellWorks/Data/Uri/IO/Static.hs view
@@ -0,0 +1,8 @@+module HaskellWorks.Data.Uri.IO.Static where++import qualified System.Directory as IO+import qualified System.IO.Unsafe as IO++homeDirectory :: FilePath+homeDirectory = IO.unsafePerformIO $ IO.getHomeDirectory+{-# NOINLINE homeDirectory #-}
+ src/HaskellWorks/Data/Uri/Location.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiWayIf             #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE TypeFamilies           #-}++module HaskellWorks.Data.Uri.Location+  ( IsPath(..)+  , Location(..)+  , toLocation+  ) where++import Antiope.Core   (ToText (..), fromText)+import Antiope.S3     (ObjectKey (..), S3Uri (..))+import Data.Maybe     (fromMaybe)+import Data.Semigroup ((<>))+import Data.Text      (Text)+import GHC.Generics   (Generic)++import qualified Data.Text       as T+import qualified System.FilePath as FP++class IsPath a s | a -> s where+  (</>) :: a -> s -> a+  (<.>) :: a -> s -> a++infixr 5 </>+infixr 7 <.>++data Location+  = S3 S3Uri+  | Local FilePath+  | HttpUri Text+  deriving (Show, Eq, Generic)++instance ToText Location where+  toText (S3 uri)       = toText uri+  toText (Local p)      = T.pack p+  toText (HttpUri uri)  = uri++instance IsPath Location Text where+  (S3      b) </> p = S3      (b </>          p)+  (Local   b) </> p = Local   (b </> T.unpack p)+  (HttpUri b) </> p = HttpUri (b </>          p)++  (S3      b) <.> e = S3      (b <.>          e)+  (Local   b) <.> e = Local   (b <.> T.unpack e)+  (HttpUri b) <.> e = HttpUri (b <.>          e)++instance IsPath Text Text where+  b </> p = T.pack (T.unpack b FP.</> T.unpack p)+  b <.> e = T.pack (T.unpack b FP.<.> T.unpack e)++instance (a ~ Char) => IsPath [a] [a] where+  b </> p = b FP.</> p+  b <.> e = b FP.<.> e++instance IsPath S3Uri Text where+  S3Uri b (ObjectKey k) </> p =+    S3Uri b (ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p))++  S3Uri b (ObjectKey k) <.> e =+    S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e))++toLocation :: Text -> Maybe Location+toLocation txt = if+  | T.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')+  | T.isPrefixOf "file://" txt'  -> Just (Local (T.unpack txt'))+  | T.isPrefixOf "http://" txt'  -> Just (HttpUri txt')+  | T.isInfixOf  "://" txt'      -> Nothing+  | otherwise                       -> Just (Local (T.unpack txt'))+  where txt' = T.strip txt++-------------------------------------------------------------------------------+stripStart :: Text -> Text -> Text+stripStart what txt = fromMaybe txt (T.stripPrefix what txt)++stripEnd :: Text -> Text -> Text+stripEnd what txt = fromMaybe txt (T.stripSuffix what txt)
+ src/HaskellWorks/Data/Uri/Show.hs view
@@ -0,0 +1,10 @@+module HaskellWorks.Data.Uri.Show+  ( tshow+  ) where++import Data.Text (Text)++import qualified Data.Text as T++tshow :: Show a => a -> Text+tshow = T.pack . show
+ src/HaskellWorks/Data/Uri/Text.hs view
@@ -0,0 +1,11 @@+module HaskellWorks.Data.Uri.Text+  ( maybeStripPrefix+  ) where++import Data.Maybe+import Data.Text  (Text)++import qualified Data.Text as T++maybeStripPrefix :: Text -> Text -> Text+maybeStripPrefix prefix text = fromMaybe text (T.stripPrefix prefix text)
+ src/HaskellWorks/Data/Uri/UriError.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.UriError+  ( UriError(..)+  , displayUriError+  , uriErrorStatus+  ) where++import Data.String+import Data.Text                  (Text)+import GHC.Generics+import HaskellWorks.Data.Uri.Show++import qualified Data.Text          as T+import qualified Network.HTTP.Types as HTTP++data UriError+  = AwsUriError+    { status :: HTTP.Status+    }+  | HttpUriError+    { status :: HTTP.Status+    }+  | RetriesFailedUriError+  | NotFound+  | GenericUriError Text+  deriving (Eq, Show, Generic)++instance IsString UriError where+  fromString = GenericUriError . T.pack++displayUriError :: UriError -> Text+displayUriError (AwsUriError s)       = tshow s+displayUriError (HttpUriError s)      = tshow s+displayUriError RetriesFailedUriError = "Multiple retries failed"+displayUriError NotFound              = "Not found"+displayUriError (GenericUriError msg) = msg++uriErrorStatus :: UriError -> Maybe Int+uriErrorStatus (AwsUriError (HTTP.Status statusCode _)) = Just statusCode+uriErrorStatus _                                        = Nothing
+ test/HaskellWorks/Data/Uri/AwsSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.AwsSpec+  ( spec+  ) where++import Antiope.Core+import Antiope.Env+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe                     (isJust)+import HaskellWorks.Data.Uri.IO.Lazy+import HaskellWorks.Data.Uri.UriError+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Antiope.S3.Types           as AWS+import qualified Data.ByteString.Lazy.Char8 as LBSC+import qualified Network.HTTP.Types         as HTTP+import qualified System.Environment         as IO++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Data.Uri.QuerySpec" $ do+  xit "stub" $ requireTest $ do+    ci <- liftIO $ IO.lookupEnv "CI" <&> isJust+    unless ci $ do+      envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn)+      result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd"+      result === Left AwsUriError+        { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" }+        }
+ test/HaskellWorks/Data/Uri/LocationSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Uri.LocationSpec+  ( spec+  ) where++import Antiope.Core                   (toText)+import Antiope.S3                     (BucketName (..), ObjectKey (..), S3Uri (..))+import Data.Semigroup                 ((<>))+import HaskellWorks.Data.Uri.Location+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.List       as List+import qualified Data.Text       as Text+import qualified Hedgehog.Gen    as Gen+import qualified Hedgehog.Range  as Range+import qualified System.FilePath as FP++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++s3Uri :: MonadGen m => m S3Uri+s3Uri = do+  let partGen = Gen.text (Range.linear 3 10) Gen.alphaNum+  bkt <- partGen+  parts <- Gen.list (Range.linear 1 5) partGen+  ext <- Gen.text (Range.linear 2 4) Gen.alphaNum+  pure $ S3Uri (BucketName bkt) (ObjectKey (Text.intercalate "/" parts <> "." <> ext))++localPath :: MonadGen m => m FilePath+localPath = do+  let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum+  parts <- Gen.list (Range.linear 1 5) partGen+  ext <- Gen.string (Range.linear 2 4) Gen.alphaNum+  pure $ "/" <> List.intercalate "/" parts <> "." <> ext++spec :: Spec+spec = describe "HaskellWorks.Assist.LocationSpec" $ do+  it "S3 should roundtrip from and to text" $ require $ property $ do+    uri <- forAll s3Uri+    tripping (S3 uri) toText toLocation++  it "LocalLocation should roundtrip from and to text" $ require $ property $ do+    path <- forAll localPath+    tripping (Local path) toText toLocation++  it "Should append s3 path" $ require $ property $ do+    loc  <- S3 <$> forAll s3Uri+    part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum+    ext  <- forAll $ Gen.text (Range.linear 2 4)  Gen.alphaNum+    toText (loc </> part <.> ext) === (toText loc) <> "/" <> part <> "." <> ext+    toText (loc </> ("/" <> part) <.> ("." <> ext)) === (toText loc) <> "/" <> part <> "." <> ext++  it "Should append s3 path" $ require $ property $ do+    loc  <- Local <$> forAll localPath+    part <- forAll $ Gen.string (Range.linear 3 10) Gen.alphaNum+    ext  <- forAll $ Gen.string (Range.linear 2 4)  Gen.alphaNum+    toText (loc </> Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ toText loc) FP.</> part FP.<.> ext)+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}