{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Symantic.HTTP.Pipes where

import Control.Arrow (first, right)
import Control.Monad (Monad(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Word (Word8)
import Prelude (fromIntegral, Num(..))
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Lens.Family as Lens
import qualified Lens.Family.State.Strict as Lens
import qualified Pipes as P
import qualified Pipes.ByteString as Pbs
import qualified Pipes.Group as Pg
import qualified Pipes.Parse as Pp
import qualified Pipes.Safe as Ps

import Symantic.HTTP.API

instance IsString () where
        fromString _ = ()

-- | Pass any executable effect to the underlying 'Monad'.
type instance MC.CanDo (P.Effect m) (MC.EffExec w) = 'False
-- | Pass any executable effect to the underlying 'Monad'.
type instance MC.CanDo (P.Proxy a' a b' b m) (MC.EffExec w) = 'False

type instance FramingMonad  (P.Producer a m r) = m
type instance FramingYield  (P.Producer a m r) = a
type instance FramingReturn (P.Producer a m r) = r

type instance FramingMonad  (P.ListT m a) = m
type instance FramingYield  (P.ListT m a) = a
type instance FramingReturn (P.ListT m a) = ()

-- | Produce 'BS.ByteString' from a 'Monad'.
produceBS ::
 IsString r =>
 Monad m =>
 m BS.ByteString -> P.Producer' BS.ByteString m r
produceBS mbs = go
        where
        go = do
                bs <- lift mbs
                if BS.null bs
                then return ""
                else do
                        P.yield bs
                        go

-- * 'NoFraming'
instance FramingEncode NoFraming (P.Producer a IO r) where
        framingEncode _framing mimeEnc p =
                right (first mimeEnc) <$> P.next p
instance FramingEncode NoFraming (P.Producer a (Ps.SafeT IO) r) where
        framingEncode _framing mimeEnc p =
                right (first mimeEnc) <$> Ps.runSafeT (P.next p)
instance FramingEncode NoFraming (P.ListT IO a) where
        framingEncode _framing mimeEnc p =
                right (\(a,n) -> (mimeEnc a, P.Select n)) <$> P.next (P.enumerate p)
instance IsString r => FramingDecode NoFraming (P.Producer a m r) where
        framingDecode _framing mimeDec mbs =
                -- TODO: use drawAll
                produceBS mbs P.>-> go
                where go = do
                        bs <- P.await
                        case mimeDec $ BSL.fromStrict bs of
                         Left err -> return $ fromString err
                         Right a -> P.yield a >> go

-- * 'NewlineFraming'
-- TODO: see how to use Pbs._unlines?
instance FramingEncode NewlineFraming (P.Producer a IO r) where
        framingEncode _framing mimeEnc p =
                right (first (newlineEncode mimeEnc))
                 <$> P.next p
instance FramingEncode NewlineFraming (P.Producer a (Ps.SafeT IO) r) where
        framingEncode _framing mimeEnc p =
                right (first (newlineEncode mimeEnc))
                 <$> Ps.runSafeT (P.next p)
instance IsString r => FramingDecode NewlineFraming (P.Producer a m r) where
        framingDecode _framing mimeDec mbs =
                Pg.concats $
                Pg.maps
                 (\p -> P.for p $ \bs ->
                        case mimeDec $ BSL.fromStrict bs of
                         Left _err -> return ()
                         Right a  -> P.yield a) $
                Lens.view Pbs.lines $
                produceBS mbs

newlineEncode :: (a -> BSL.ByteString) -> a -> BSL.ByteString
newlineEncode mimeEnc a = mimeEnc a <> BSL.singleton (fromIntegral (Char.ord '\n'))

instance FramingEncode NetstringFraming (P.Producer a IO r) where
        framingEncode _framing mimeEnc p =
                right (first (encodeNetstring mimeEnc))
                 <$> P.next p
instance FramingEncode NetstringFraming (P.Producer a (Ps.SafeT IO) r) where
        framingEncode _framing mimeEnc p =
                right (first (encodeNetstring mimeEnc))
                 <$> Ps.runSafeT (P.next p)
instance IsString r => FramingDecode NetstringFraming (P.Producer a m r) where
        framingDecode _framing mimeDec mbs =
                Pg.concats $
                parseMany
                 (Pp.execStateT $ decodeNetstring @r mimeDec)
                 (produceBS mbs)

digit0, digit9 :: Word8
colon, comma :: Word8
newline :: Word8
digit0  = fromIntegral (Char.ord '0')
digit9  = fromIntegral (Char.ord '9')
colon   = fromIntegral (Char.ord ':')
comma   = fromIntegral (Char.ord ',')
newline = fromIntegral (Char.ord '\n')

encodeNetstring :: (a -> BSL.ByteString) -> a -> BSL.ByteString
encodeNetstring mimeEnc a =
        let bs = mimeEnc a in
        BSL8.pack (show (BSL8.length bs))
         <> ":" <> bs <> ","

decodeNetstring ::
 IsString r =>
 Monad m =>
 (BSL.ByteString -> Either String a) ->
 ParserP BS.ByteString a m r
decodeNetstring mimeDec = do
        lenBSs <- Lens.zoom (Pbs.span (\b -> digit0 <= b && b <= digit9)) drawAllP
        case lenBSs >>= BS.unpack of
         [] -> return "empty length"
         w0:_:_ | w0 == digit0 -> return "leading zero"
         lenWs -> do
                let len = List.foldl' (\acc d -> acc * 10 + (fromIntegral d - digit0)) 0 lenWs
                colonW <- drawByteP
                if colonW /= Just colon
                then return "colon expected"
                else do
                        -- TODO: make mimeDecode directly able to use Pipes?
                        dataBS <- BSL.fromChunks <$> Lens.zoom (Pbs.splitAt len) drawAllP
                        commaW <- drawByteP
                        if commaW /= Just comma
                        then return "comma expected"
                        else do
                                case mimeDec dataBS of
                                 Left err -> return $ fromString err
                                 Right a -> do
                                        yieldP a
                                        decodeNetstring mimeDec

-- * Type 'P.Parser'

-- | A 'P.Parser', which is itself a 'P.Producer',
-- and thus can 'yieldP' immediately.
type ParserP inp out m r =
 forall x. Pp.StateT (P.Producer inp m x) (P.Producer out m) r

yieldP :: Monad m => out -> ParserP inp out m ()
yieldP = lift . P.yield

drawP :: Monad m => ParserP inp out m (Maybe inp)
drawP = P.hoist lift Pp.draw

drawAllP :: Monad m => ParserP inp out m [inp]
drawAllP = P.hoist lift Pp.drawAll

drawByteP :: Monad m => ParserP BS.ByteString out m (Maybe Word8)
drawByteP = P.hoist lift Pbs.drawByte

unDrawP :: Monad m => inp -> ParserP inp out m ()
unDrawP = P.hoist lift . Pp.unDraw

-- | @'parseMany f'@ groups a 'P.Producer' of 'BS.ByteString's
-- into a series of 'P.Producer's delimited by f,
-- where the delimiter is dropped
parseMany ::
 Monad m =>
 (P.Producer a m r -> P.Producer b m (P.Producer a m r)) ->
 P.Producer a m r ->
 Pg.FreeT (P.Producer b m) m r
parseMany f = Pg.FreeT . go0
        where
        go0 p = do
                P.next p >>= \case
                 Left r -> return (Pg.Pure r)
                 Right (bs, p') -> return $ Pg.Free (go1 (P.yield bs >> p'))
        go1 p = Pg.FreeT . go0 <$> f p

{-
-- * Type |Lens'|
-- | Package agnostic lens.
type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
(^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
a ^. lens = getConstant (lens Constant a)
-}