{-# LANGUAGE OverloadedStrings #-}
module Main
    ( main )
where

import State.Types ( State, ChapterId, mkChapterId, CommentId
                   , Comment, getCounts, findComments, mkCommentId
                   , addChapter, Comment(..), addComment, SessionId(..)
                   , getLastInfo, SessionInfo(..), getChapterComments
                   , getChapterURI
                   )
import qualified State.Mem
import qualified State.Disk
import qualified State.SQLite

import Network.URI ( URI, parseRelativeReference )
import Data.Function ( on )
import Data.List ( sort, sortBy, intercalate )
import Data.Maybe ( fromJust )
import Data.Array.Unboxed ( UArray, listArray, bounds, (!) )
import Data.Char ( isPrint, chr )
import System.Directory ( createDirectory, getTemporaryDirectory, removeDirectoryRecursive )
import System.FilePath ( (</>) )
import Control.Monad ( replicateM, forM_, unless, join, replicateM_, foldM )
import Control.Monad.Random ( getRandomR, getRandom )
import Control.Applicative ( (<$>), (<*>) )
import Control.Exception ( finally )
import System.IO ( stdout, hFlush )
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Text.Encoding as E

withTemporaryDirectory :: (FilePath -> IO a) -> IO a
withTemporaryDirectory act = do
  t <- getTemporaryDirectory
  let choices = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
      rndChar = (choices !!) <$> getRandomR (0, length choices - 1)
  randPart <- replicateM 8 rndChar
  let d = t </> ("test-" ++ randPart)
  createDirectory d
  act d `finally` removeDirectoryRecursive d

data StoreType = Disk | SQLite | Mem deriving (Show, Eq, Enum, Bounded)

mkStore :: FilePath -> StoreType -> IO State
mkStore d t = case t of
                Mem    -> State.Mem.new
                Disk   -> State.Disk.new (d </> "flat-file")
                SQLite -> State.SQLite.new (d </> "state.db")

withRandomStores :: ((StoreType, State) -> (StoreType, State) -> IO a) -> IO a
withRandomStores act = do
  elim <- getRandomR (0, 2)
  let (before, (_:after)) = splitAt elim [Disk, SQLite, Mem]
      ts = before ++ after
  withTemporaryDirectory $ \d ->
      do [st1, st2] <- zip ts <$> mapM (mkStore d) ts
         act st1 st2

data Operation = GetCounts (Maybe ChapterId)
               | FindComments CommentId
               | AddChapter ChapterId [CommentId] (Maybe URI)
               | AddComment CommentId (Maybe ChapterId) Comment
               | GetLastInfo SessionId
               | GetChapterComments ChapterId
               | GetChapterURI ChapterId
                 deriving Show

data Result = Unit
            | LastInfo (Maybe SessionInfo)
            | Counts [(CommentId, Int)]
            | Comments [Comment]
            | ChapterComments [(CommentId, Comment)]
            | ChapterURI (Maybe URI)
              deriving (Eq, Show)

applyOp :: Operation -> State -> IO Result
applyOp (GetCounts p) st               = Counts . sort <$> getCounts st p
applyOp (FindComments cId) st          = Comments <$> findComments st cId
applyOp (AddChapter chId cIds mURI) st = addChapter st chId cIds mURI >> return Unit
applyOp (AddComment cId mChId c) st    = addComment st cId mChId c >> return Unit
applyOp (GetLastInfo sId) st           = LastInfo <$> getLastInfo st sId
applyOp (GetChapterComments chId) st   = ChapterComments <$> getChapterComments st chId
applyOp (GetChapterURI chId) st        = ChapterURI <$> getChapterURI st chId

choice :: [a] -> IO a
choice xs = (xs !!) <$> getRandomR (0, length xs - 1)

shuffle :: [a] -> IO [a]
shuffle xs = do
  is <- replicateM (length xs) getRandom :: IO [Double]
  return $ map snd $ sortBy (compare `on` fst) $ zip is xs

randomOp :: IO Operation
randomOp = join $ choice $ readOps ++ writeOps

randomWriteOp :: IO Operation
randomWriteOp = join $ choice writeOps

readOps :: [IO Operation]
readOps = [ GetCounts <$> maybeRand randomChapterId
          , FindComments <$> randomCommentId
          , GetLastInfo <$> randomSessionId
          , GetChapterComments <$> randomChapterId
          , GetChapterURI <$> randomChapterId
          ]

writeOps :: [IO Operation]
writeOps = [ let cIds = do
                   n <- getRandomR (0, 100)
                   replicateM n $ randomCommentId
             in AddChapter <$>
                randomChapterId <*>
                cIds <*>
                maybeRand randomRelativeReference
           , AddComment
             <$> randomCommentId
             <*> maybeRand randomChapterId
             <*> randomComment
           ]

maybeRand :: IO a -> IO (Maybe a)
maybeRand x = do
  doGen <- getRandom
  if doGen then Just <$> x else return Nothing

randomChapterId :: IO ChapterId
randomChapterId = fromJust . mkChapterId <$> randomText

randomCommentId :: IO CommentId
randomCommentId = fromJust . mkCommentId <$> randomText

randomSessionId :: IO SessionId
randomSessionId = SessionId <$> randomBS

randomRelativeReference :: IO URI
randomRelativeReference = do
  nSegs <- getRandomR (0, 5)
  let getSeg = join $ choice
               [ choice ["a", "b", "c"]
               , do segLength <- getRandomR (1, 10)
                    replicateM segLength $
                               choice $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
               ]
  fromJust . parseRelativeReference . ('/':) . intercalate "/" <$> replicateM nSegs getSeg

usableChars :: UArray Int Char
usableChars = listArray (0, length cs - 1) cs
    where
      cs = filter isPrint [chr 0..chr 127]

randomBS :: IO B.ByteString
randomBS = E.encodeUtf8 <$> randomText

randomText :: IO T.Text
randomText = join $ choice [commonValue, completelyRandom]
    where
      completelyRandom = do
        let randomChar = do
              i <- getRandomR $ bounds usableChars
              return $ usableChars ! i
        n <- getRandomR (2, 40)
        T.pack <$> replicateM n randomChar
      commonValue = choice ["alpha", "beta", "gamma", "delta"]

randomOps :: Int -> Int -> IO [Operation]
randomOps minOps maxOps = do
  n <- getRandomR (minOps, maxOps)
  replicateM n randomOp

doRandomOperations :: (StoreType, State) -> (StoreType, State) -> IO ()
doRandomOperations (ty1, st1) (ty2, st2) = do
  ops <- randomOps 10 500
  _ <- foldM (\soFar op -> do
                r1 <- applyOp op st1
                r2 <- applyOp op st2
                unless (r1 == r2) $ do
                  putStrLn $ "Got different results for " ++ show op ++ " on " ++
                           show ty1 ++ " and " ++ show ty2
                  forM_ (soFar [op]) print
                  putStrLn $ "Results were:"
                  print ty1
                  print r1
                  putStrLn $ replicate 50 '-'
                  print ty2
                  print r2
                  putStrLn $ replicate 50 '-'
                  error "Test failed"
                return (soFar . (op:))) id ops
  return ()

randomComment :: IO Comment
randomComment = Comment
                <$> randomText
                <*> randomText
                <*> maybeRand randomText
                <*> randomTime
                <*> randomSessionId
    where
      -- This one's a little sketchy, because we expect that the time
      -- of each comment will be monotonically non-decreasing. The
      -- stores should act sanely in the face of arbitrary time
      -- values, however, so I'll leave it as a completely random
      -- value.
      randomTime = realToFrac <$> (getRandomR (0, 2**32) :: IO Double)

-- |Test that adding a comment to a node makes it show up at the end
-- of the list of comments when it is subsequently loaded
storeLoadComment :: State -> IO ()
storeLoadComment st = do
  cId <- randomCommentId
  cs <- findComments st cId
  c <- randomComment
  addComment st cId Nothing c
  cs' <- findComments st cId
  unless (cs' == (cs ++ [c])) $
         error "Expected the added comment to come up after adding"

-- |Test that a comment for a node that is part of a chapter is
-- returned when we request comments for this chapter
storeLoadCommentChapter :: State -> IO ()
storeLoadCommentChapter st = do
  chId <- randomChapterId
  cId <- randomCommentId
  ref <- maybeRand randomRelativeReference
  addChapter st chId [cId] ref
  cs <- getChapterComments st chId
  c <- randomComment
  addComment st cId (Just chId) c
  let e = (cId, c)
  cs' <- getChapterComments st chId
  unless (length cs' == length cs + 1) $
         error $ unlines [ "Adding a comment to a chapter didn't add:"
                         , show cs
                         , show cs'
                         ]
  unless (e `elem` cs') $
         error "The expected pair is not part of the comments"

chapterCommentsOrderedByDate :: State -> IO ()
chapterCommentsOrderedByDate st = do
  cs <- getChapterComments st =<< randomChapterId
  let dates = map (cDate . snd) cs
      ordered = and $ zipWith (>=) dates (drop 1 dates)
  unless ordered $
         error "The comments are not ordered by date"

-- |Test some property (possibly with a side-effect)
runArbitraryTest :: State -> IO ()
runArbitraryTest st = ($ st) =<< choice allProps

-- |All defined properties
allProps :: [State -> IO ()]
allProps = [ storeLoadComment
           , chapterCommentsOrderedByDate
           , storeLoadCommentChapter
           ]

-- |Run all of the properties at least once, in an arbitrary order
runRandomTests :: State -> IO ()
runRandomTests st = do
  m <- getRandomR (0, 100)
  let randomProps = replicate m $ runArbitraryTest st
  props <- shuffle $ map ($ st) allProps ++ randomProps
  sequence_ props

main :: IO ()
main = do
  putStr "Testing store properties: "
  hFlush stdout

  -- Test properties of stores
  withTemporaryDirectory $ \d ->
      forM_ [minBound .. maxBound] $ \typ -> do
         putStr $ show typ ++ " "
         hFlush stdout

         st <- mkStore d typ

         -- Run some tests on an empty store
         runRandomTests st

         replicateM 10 $ do
           putStr "."
           hFlush stdout

           -- Do some random operations to get the store into a
           -- different state
           n <- getRandomR (10, 500)
           ops <- replicateM n randomWriteOp
           forM_ ops $ \op -> applyOp op st

           runRandomTests st

  putStrLn "done.\nRunning store consistency tests"
  -- Test that completely randomized operations have the same
  -- observable state between different store types
  replicateM_ 100 $ do
         withRandomStores doRandomOperations
         putStr "."
         hFlush stdout

  putStrLn "\ndone. Tests passed."