{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}

module Model.Types.FileSpec where

import TestImport
import TestInstances ()

import Data.Conduit
import qualified Data.Conduit.Combinators as C

import Data.Ratio ((%))

import System.FilePath
import Data.Time

import qualified Data.Map as Map

import Test.QuickCheck.Random (QCGen (..))
import qualified System.Random.SplitMix as SM

import qualified Data.ByteString as BS


scaleRatio :: Rational -> Int -> Int
scaleRatio r = ceiling . (* r) . fromIntegral

arbitraryBS :: Int -> Gen ByteString
arbitraryBS l = MkGen $ \(QCGen g0) _ -> if
    | l <= 0    -> BS.empty
    | otherwise -> fst $ BS.unfoldrN l gen g0
  where
    gen :: SM.SMGen -> Maybe (Word8, SM.SMGen)
    gen !g = Just (fromIntegral w64, g')
      where
        ~(w64, g') = SM.nextWord64 g


newtype LargeFile m = LargeFile { getLargeFile :: File m }

instance Monad m => Arbitrary (LargeFile m) where
  arbitrary = do
    fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
    fileContent <- oneof
      [ pure Nothing
      , pure . Just $ return ()
      , oneof
        [ Just . yield <$> (arbitraryBS =<< choose (1,1e3))
        , Just . yield <$> (arbitraryBS =<< choose (succ 1e3,1e6))
        , Just . yield <$> (arbitraryBS =<< choose (succ 1e6,20e6))
        ]
      , oneof
        [ Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (1,1e3)) =<< choose (2,100))
        , Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (succ 1e3,1e6)) =<< choose (2,10))
        , Just . C.yieldMany <$> (flip vectorOf (arbitraryBS =<< choose (succ 1e6,20e6)) =<< choose (2,10))
        ]
      ]
    return $ LargeFile File{..}
    where
      inZipRange :: UTCTime -> Bool
      inZipRange time
        | time > UTCTime (fromGregorian 1980 1 1) 0
        , time < UTCTime (fromGregorian 2107 1 1) 0
        = True
        | otherwise
        = False

instance (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where
  arbitrary = C.sourceLazy <$> arbitrary

instance Monad m => Arbitrary (File m) where
  arbitrary = do
    fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
    fileContent <- oneof
      [ pure Nothing
      , Just <$> scale (scaleRatio $ 7 % 8) arbitrary
      ]
    return File{..}
    where
      inZipRange :: UTCTime -> Bool
      inZipRange time
        | time > UTCTime (fromGregorian 1980 1 1) 0
        , time < UTCTime (fromGregorian 2107 1 1) 0
        = True
        | otherwise
        = False

instance Arbitrary FileReference where
  arbitrary = pureFileToFileReference <$> arbitrary

instance Arbitrary a => Arbitrary (FileFieldUserOption a) where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary add => Arbitrary (FileReferenceTitleMap FileReference add) where
  arbitrary = do
    fRefs <- arbitrary
    fmap (review _FileReferenceFileReferenceTitleMap . Map.fromList) . for fRefs $ \FileReference{..} -> (fileReferenceTitle, ) . (fileReferenceContent, fileReferenceModified, ) <$> arbitrary

instance Arbitrary (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Arbitrary (FileField fileid) where
  arbitrary = genericArbitrary
  shrink = genericShrink

deriving newtype instance Arbitrary FileContentReference
instance CoArbitrary FileContentReference
instance Function FileContentReference
deriving newtype instance Arbitrary FileContentChunkReference
instance CoArbitrary FileContentChunkReference
instance Function FileContentChunkReference

spec :: Spec
spec = do
  parallel $ do
    lawsCheckHspec (Proxy @PureFile)
      [ eqLaws, ordLaws, showLaws ]
    lawsCheckHspec (Proxy @FileReference)
      [ eqLaws, ordLaws, hashableLaws, binaryLaws, jsonLaws ]
    lawsCheckHspec (Proxy @(FileFieldUserOption Bool))
      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
    lawsCheckHspec (Proxy @(FileReferenceTitleMap FileReference (FileFieldUserOption Bool)))
      [ eqLaws, ordLaws, semigroupLaws, monoidLaws, semigroupMonoidLaws, idempotentSemigroupLaws ]
    lawsCheckHspec (Proxy @(FileField FileReference))
      [ eqLaws, ordLaws, jsonLaws ]
    lawsCheckHspec (Proxy @FileContentChunkReference)
      [ eqLaws, ordLaws, showLaws, persistFieldLaws, pathPieceLaws, httpApiDataLaws, jsonLaws, hashableLaws, binaryLaws ]
    lawsCheckHspec (Proxy @FileContentReference)
      [ eqLaws, ordLaws, showLaws, persistFieldLaws, pathPieceLaws, httpApiDataLaws, jsonLaws, hashableLaws, binaryLaws ]

  describe "minioFileChunkReference" . it "is a prism" . property $ isPrism minioFileChunkReference
  describe "minioFileReference" . it "is a prism" . property $ isPrism minioFileReference
