{-# LANGUAGE OverloadedStrings
           , GeneralizedNewtypeDeriving
           , MultiParamTypeClasses
           , RecordWildCards
           , TypeFamilies
           , TupleSections
           , FlexibleContexts
           , Rank2Types
           #-}
module Network.Aliyun
  ( Yun(..)
  , YunConf(..)
  , YunEnv
  , BucketQuery(..)
  , runYun
  , runYunWithManager
  , listService
  , putBucket
  , getBucket
  , getBucketContents
  , getBucketContentsLifted
  , getBucketACL
  , deleteBucket
  , putObject
  , putObjectStr
  , putObjectStream
  , putObjectFile
  , getObject
  , getObjectRange
  , getObjectStream
  , getObjectRangeStream
  , copyObject
  , headObject
  , deleteObject
  , deleteObjects
  , module Network.Aliyun.Types
  ) where

import qualified Prelude as P
import BasicPrelude
import qualified Filesystem.Path as Path
import qualified Filesystem.Path.CurrentOS as Path
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Encoding as T
import Data.Time.Clock (UTCTime(UTCTime))

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Control
import Control.Monad.Base
import qualified Control.Exception.Lifted as Lifted
import qualified Blaze.ByteString.Builder as B

import Data.Maybe (maybeToList)
import Data.Default (Default)
import Data.Time (getCurrentTime, formatTime)
import qualified Data.Conduit as C
import qualified Data.Conduit.Binary as C
import qualified Data.Conduit.List as C
import Data.Aeson (FromJSON)
import Text.XML.ToJSON (parseXML)

import qualified System.IO as IO
import System.Locale (defaultTimeLocale)
import Network.HTTP.Conduit
import qualified Network.HTTP.Types as W

import Network.Aliyun.Types
import Network.Aliyun.Utils

data YunConf = YunConf
  { yunHost :: !ByteString
  , yunId   :: !ByteString
  , yunKey  :: !ByteString
  }

type YunEnv = (YunConf, Manager)

newtype Yun a = Yun { unYun :: ReaderT YunEnv (ResourceT IO) a }
    deriving (Functor, Applicative, Monad, MonadIO, C.MonadResource, C.MonadThrow, C.MonadUnsafeIO)

instance MonadBase IO Yun where
    liftBase = Yun . liftBase

instance MonadBaseControl IO Yun where
    newtype StM Yun a = YunStM { unYunStM :: StM (ReaderT YunEnv (ResourceT IO)) a }
    liftBaseWith f = Yun . liftBaseWith $ \runInBase -> f $ liftM YunStM . runInBase . unYun
    restoreM = Yun . restoreM . unYunStM

askConf :: Yun YunConf
askConf     = fst <$> Yun ask
askManager :: Yun Manager
askManager  = snd <$> Yun ask
asksConf :: (YunConf -> a) -> Yun a
asksConf f  = f <$> askConf

-- | run yun monad with a new http manager.
runYun :: YunConf -> Yun a -> IO a
runYun conf yun = withManager $ \man -> runReaderT (unYun yun) (conf, man)

-- | run yun monad with provided http manager.
runYunWithManager :: Manager -> YunConf -> Yun a -> ResourceT IO a
runYunWithManager man conf yun = runReaderT (unYun yun) (conf, man)

formatNow :: IO ByteString
formatNow = S.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" <$> getCurrentTime

data RequestHints = RequestHints
  { hMethod  :: !ByteString
  , hPath    :: !ByteString
  , hQuery   :: !ByteString
  , hHeaders :: !W.RequestHeaders
  , hBody    :: !(RequestBody Yun)
  , hNeedMd5 :: !Bool
  }

instance Default RequestHints where
    def = RequestHints "GET" "/" "" [] (RequestBodyLBS empty) False

mkRequest :: RequestHints -> Yun (Request Yun)
mkRequest RequestHints{..} = do
    conf <- askConf
    time <- liftIO formatNow
    let req = def { host            = yunHost conf
                  , method          = hMethod
                  , path            = hPath
                  , queryString     = hQuery
                  , requestHeaders  = ("Date", time) : hHeaders
                  , requestBody     = hBody
                  }
    return $ authorizeRequest req (yunId conf) (yunKey conf) hNeedMd5

streamRequest :: RequestHints -> Yun (Response (C.ResumableSource Yun S.ByteString))
streamRequest hints = do
    req <- mkRequest hints
    askManager >>= http req

lbsRequest :: RequestHints -> Yun (Response LByteString)
lbsRequest hints =
    streamRequest hints >>= lbsResponse

xmlResponse :: (C.MonadThrow m, FromJSON a) => Response LByteString -> m a
xmlResponse = parseXML . responseBody

-- | list all the buckets.
listService :: Yun BucketList
listService =
    xmlResponse =<< lbsRequest def

-- | create or update a bucket.
putBucket :: ByteString -> Maybe ByteString -> Yun LByteString
putBucket name macl = do
    let hds = maybeToList $ ("x-oss-acl",) <$> macl
    responseBody <$>
        lbsRequest def{ hMethod  = "PUT"
                      , hPath    = "/"++name
                      , hHeaders = hds
                      }

-- | bucket item query conditions.
data BucketQuery = BucketQuery
  { qryPrefix       :: !ByteString
  , qryMaxKeys      :: !Int
  , qryMarker       :: !(Maybe Text)
  , qryDelimiter    :: !(Maybe Char)
  }
instance Default BucketQuery where
    def = BucketQuery "" 1000 Nothing Nothing

-- | query bucket items.
getBucket :: ByteString -> BucketQuery -> Yun Bucket
getBucket name qry =
    xmlResponse =<< lbsRequest def{ hPath = "/"++name, hQuery=qs }
  where
    qs = S.concat
           [ "prefix=", qryPrefix qry
           , "&max-keys=", S.pack $ P.show (qryMaxKeys qry)
           , maybe "" (("&marker="++) . T.encodeUtf8) (qryMarker qry)
           , maybe "" (("&delimiter="++) . S.singleton) (qryDelimiter qry)
           ]

-- | Generic version of `getBucketContents'.
getBucketContentsLifted :: Monad m => (forall a. Yun a -> m a) -> ByteString -> ByteString -> C.Source m BucketContent
getBucketContentsLifted liftYun name prefix = loop def{qryDelimiter=Just '/', qryPrefix=prefix}
  where
    withFilePath f = either id id . Path.toText . f . Path.fromText

    loop qry = do
        bucket <- lift $ liftYun $ getBucket name qry
        -- yield directories
        mapM_ ( C.yield
              . flip ContentDirectory (UTCTime (toEnum 60000) 0)
              . withFilePath Path.dirname
              )
              (bucketDirectories bucket)
        -- yield files
        mapM_ ( C.yield
              . ContentFile
              . (\f -> f{fileKey = withFilePath Path.filename (fileKey f)})
              )
              (bucketContents bucket)
        when (bucketIsTruncated bucket) $
            loop qry{qryMarker=bucketNextMarker bucket}

-- | get bucket items streamlined, support more then 1000 items.
getBucketContents :: ByteString -> ByteString -> C.Source Yun BucketContent
getBucketContents = getBucketContentsLifted id

-- | query bucket acl info.
getBucketACL :: ByteString -> Yun BucketACL
getBucketACL name =
    xmlResponse =<< lbsRequest def{ hPath = S.concat ["/", name, "?acl"] }

-- | delete bucket by name
deleteBucket :: ByteString -> Yun LByteString
deleteBucket name =
    responseBody <$>
        lbsRequest def{ hMethod = "DELETE"
                      , hPath   = "/"++name
                      }

-- | upload a file.
putObject :: ByteString -> ByteString -> RequestBody Yun -> Yun LByteString
putObject bucket name body =
    responseBody <$>
        lbsRequest def{ hMethod = "PUT"
                      , hPath   = S.concat ["/", bucket, "/", name]
                      , hBody   = body
                      }

-- | Upload a file with `LByteString' content.
putObjectStr :: ByteString -> ByteString -> LByteString -> Yun LByteString
putObjectStr bucket name body = putObject bucket name (RequestBodyLBS body)

-- | Upload a file from disk streamlined.
putObjectFile :: ByteString -> ByteString -> IO.FilePath -> Yun LByteString
putObjectFile bucket name path =
    Lifted.bracket
        (liftIO $ IO.openBinaryFile path IO.ReadMode)
        (liftIO . IO.hClose)
        (\h -> do
           size <- fromIntegral <$> liftIO (IO.hFileSize h)
           let src  = C.sourceHandle h C.$= C.map B.fromByteString
           putObjectStream bucket name size src
        )

-- | Upload a file from a source streamlined.
-- aliyun don't support chunked tranfer-encoding, so size must be passed.
putObjectStream :: ByteString -> ByteString -> Int64 -> C.Source Yun B.Builder -> Yun LByteString
putObjectStream bucket name size source =
    putObject bucket name (RequestBodySource size source)

-- TODO put object multipart

-- | download a file.
getObject :: ByteString -> ByteString -> Yun LByteString
getObject bucket name = getObjectRange bucket name Nothing

-- | download a file streamlined.
getObjectStream :: ByteString -> ByteString -> Yun (C.ResumableSource Yun S.ByteString)
getObjectStream bucket name = getObjectRangeStream bucket name Nothing

-- | download a range of file.
getObjectRange :: ByteString -> ByteString -> Maybe ByteString -> Yun LByteString
getObjectRange bucket name mrange = do
    let hds = maybeToList $ ("Range",) . ("bytes="++) <$> mrange
    responseBody <$>
        lbsRequest def{ hPath    = S.concat ["/", bucket, "/", name]
                      , hHeaders = hds
                      }

-- | download a range of file streamlined.
getObjectRangeStream :: ByteString -> ByteString -> Maybe ByteString -> Yun (C.ResumableSource Yun S.ByteString)
getObjectRangeStream bucket name mrange = do
    let hds = maybeToList $ ("Range",) . ("bytes="++) <$> mrange
    responseBody <$>
        streamRequest def{ hPath    = S.concat ["/", bucket, "/", name]
                      , hHeaders = hds
                      }

-- | copy an object.
copyObject :: ByteString -> ByteString -> ByteString -> Yun CopyResult
copyObject bucket name source =
    xmlResponse =<<
        lbsRequest def{ hMethod  = "PUT"
                      , hPath    = S.concat ["/", bucket, "/", name]
                      , hHeaders = [("x-oss-copy-source", source)]
                      }

-- | HEAD request get object.
headObject :: ByteString -> ByteString -> Yun LByteString
headObject bucket name =
    responseBody <$>
        lbsRequest def{ hMethod = "HEAD"
                      , hPath   = S.concat ["/", bucket, "/", name]
                      }

-- | delete object.
deleteObject :: ByteString -> ByteString -> Yun LByteString
deleteObject bucket name =
    responseBody <$>
        lbsRequest def{ hMethod = "DELETE"
                      , hPath   = S.concat ["/", bucket, "/", name]
                      }

-- | batch delete multiple objects.
deleteObjects :: ByteString -> [ByteString] -> Bool -> Yun DeleteResult
deleteObjects bucket names verbose = do
    let body = L.fromChunks $
          [ "<Delete><Quiet>"
          , if verbose then "false" else "true"
          , "</Quiet>"
          ] ++
          concat [["<Object><Key>", name, "</Key></Object>"] | name <- names] ++
          [ "</Delete>" ]
    xmlResponse =<<
        lbsRequest def{ hMethod  = "POST"
                      , hPath    = S.concat ["/", bucket, "?delete"]
                      , hBody    = RequestBodyLBS body
                      , hNeedMd5 = True
                      }