content: {-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators, ViewPatterns, Arrows, CPP #-}
  
  -- Stuff on disk on the server
  module Development.Bake.Server.Store(
      Store, newStore, storeSave, storeSQL,
      PatchInfo(..), paAlive, storeIsPatch, storePatch, storeAlive,
      PointInfo(..), poTest, storePoint, storeSupersetPass,
      StateInfo(..), storeStateList, storeState,
      RunId, storeRunList, storeStateFile, storeRunFile,
      storeItemsDate,
      storeSkip,
      storeExtra, storeExtraAdd,
      Update(..), storeUpdate
      ) where
  
  import Development.Bake.Server.Database
  import General.Database
  import Development.Bake.Core.Type
  import Development.Bake.Core.Message
  import qualified Data.Set as Set
  import qualified Data.Map as Map
  import General.Extra
  import General.BigString
  import Data.Char
  import Data.List.Extra
  import System.IO.Unsafe
  import Data.Monoid
  import Data.Maybe
  import Control.Concurrent.Extra
  import Data.Tuple.Extra
  import Control.Applicative
  import Control.Monad.Extra
  import System.Directory
  import Database.SQLite.Simple hiding (NamedParam(..))
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import qualified Data.Text.Lazy as TL
  import qualified Data.Text.Lazy.IO as TL
  import System.FilePath
  import Control.DeepSeq
  import Control.Exception
  import Prelude
  
  #if OPALEYE
  import qualified Opaleye as O
  import Control.Arrow
  #endif
  
  
  ---------------------------------------------------------------------
  -- DATA TYPES
  
  data PointInfo = PointInfo
      {poTodo :: Maybe (Set.Set Test)
      ,poPass :: Set.Set (Maybe Test)
      ,poFail :: Set.Set (Maybe Test) -- may be in both pass and fail
      } deriving Show
  
  instance Monoid PointInfo where
      mempty = PointInfo Nothing Set.empty Set.empty
      mappend (PointInfo x1 x2 x3) (PointInfo y1 y2 y3) = PointInfo (x1 <> y1) (x2 <> y2) (x3 <> y3)
  
  poTest :: PointInfo -> Maybe Test -> Maybe Bool
  poTest PointInfo{..} t
      | t `Set.member` poFail = Just False
      | t `Set.member` poPass = Just True
      | Just t <- t, Just todo <- poTodo, not $ t `Set.member` todo = Just True -- It's not applicable, and thus passes
      | otherwise = Nothing
  
  
  data PatchInfo = PatchInfo
      {paAuthor :: Author
      ,paQueued :: UTCTime
      ,paStart :: Maybe UTCTime
      ,paDelete :: Maybe UTCTime
      ,paSupersede :: Maybe UTCTime
      ,paReject :: Maybe (UTCTime, Map.Map (Maybe Test) (State, [Patch]))
      ,paPlausible :: Maybe UTCTime
      ,paMerge :: Maybe UTCTime
      }
      deriving Show
  
  paAlive :: PatchInfo -> Bool
  paAlive PatchInfo{..} = isNothing paDelete && isNothing paSupersede && isNothing paReject && isNothing paMerge
  
  data StateInfo = StateInfo
      {stCreated :: UTCTime
      ,stSource :: Maybe Point
      ,stDuration :: Maybe Seconds
      }
  
  
  ---------------------------------------------------------------------
  -- CACHED INFORMATION
  
  data Cache = Cache
      {cachePointId :: PointId -> IO Point
      ,cachePatch :: Patch -> IO (PatchId, PatchInfo)
      ,cacheState :: State -> IO (StateId, StateInfo)
      ,cachePoint :: Point -> IO (PointId, PointInfo)
      ,cacheSkip :: IO (Map.Map Test String)
      ,cacheAlive :: IO (Set.Set Patch)
      ,cacheSupersetPass :: Point -> IO (Set.Set Test)
      }
  
  newCache :: Connection -> IO Cache
  newCache conn = do
      cachePointId <- memoIO1 $ \pt -> do
          [(s,ps)] <- sqlSelect conn (ptState, ptPatches) [ptId %== pt]
          [Only s] <- sqlSelect conn (Only saState) [saId %== s]
          ps <- forM (fromPatchIds ps) $ \p -> do
              [Only p] <- sqlSelect conn pcPatch [pcId %== p]; return p
          return (s, ps)
  
      cachePatch <- memoIO1 $ \p -> do
          [(row, paAuthor, paQueue, paStart, paDelete, paSupersede, paReject, paPlausible, paMerge)] <-
              sqlSelect conn (pcId,pcAuthor,pcQueue,pcStart,pcDelete,pcSupersede,pcReject,pcPlausible,pcMerge)
              [pcPatch %== p]
          reject <- if isNothing paReject then return Nothing else unsafeInterleaveIO $ do
              ts <- sqlSelect conn (rjTest, rnPoint) [distinct rjTest, rjPatch %== row, rjRun %==% rnId]
              ts <- mapM (\(a,b) -> (a,) <$> cachePointId b) ts
              return (Just (fromJust paReject, Map.fromList ts))
          return (row, PatchInfo paAuthor paQueue paStart paDelete paSupersede reject paPlausible paMerge)
  
      cacheState <- memoIO1 $ \s -> do
          let checkOne msg [x] = [x]
              checkOne msg xs = error $ "checkOne, expected 1 but got " ++ show (length xs) ++ ", " ++ msg
          [(row, sCreate, sPoint, sDuration)] <- checkOne ("Loading up state " ++ show s) <$> sqlSelect conn (saId, saCreate, saPoint, saDuration) [saState %== s]
          pt <- maybe (return Nothing) (fmap Just . cachePointId) sPoint
          return (row, StateInfo sCreate pt sDuration)
  
      cachePoint <- memoIO1 $ \(s,ps) -> do
          s <- fst <$> cacheState s
          ps <- patchIds <$> mapM (fmap fst . cachePatch) ps
          res <- sqlSelect conn ptId [ptState %== s, ptPatches %== ps]
          pt <- case res of
              [] -> sqlInsert conn ptTable (s, ps)
              [Only x] -> return x
              _ -> error $ "ensurePoint, multiple points found"
          tests <- unsafeInterleaveIO $ sqlSelect conn tsTest [tsPoint %== pt]
          pass <- unsafeInterleaveIO $ sqlSelect conn rnTest [distinct rnTest, rnPoint %== pt, rnSuccess %== True]
          fail <- unsafeInterleaveIO $ sqlSelect conn rnTest [distinct rnTest, rnPoint %== pt, rnSuccess %== False]
          return $ (,) pt $ PointInfo
              (if null tests then Nothing else Just $ Set.fromList $ mapMaybe fromOnly tests)
              (Set.fromList $ map fromOnly pass) (Set.fromList $ map fromOnly fail)
  
      cacheSkip <- memoIO0 $ do
          Map.fromList <$> sqlSelect conn (skTest, skComment) []
  
      cacheAlive <- memoIO0 $ do
          ps <- sqlSelect conn pcPatch [nullP pcDelete, nullP pcSupersede, nullP pcReject, nullP pcMerge]
          return $ Set.fromList $ map fromOnly ps
  
      cacheSupersetPass <- memoIO1 $ \(s, ps) -> do
          s <- fst <$> cacheState s
          ps <- mapM (fmap fst . cachePatch) ps
          let f success = do
                  xs <- sqlSelect conn rnTest [rnPoint %==% ptId, ptState %== s, likeP ptPatches $ patchIdsSuperset ps, rnSuccess %== success]
                  return $ Set.fromList $ mapMaybe fromOnly xs
          liftM2 Set.difference (f True) (f False)
  
      return Cache{..}
  
  
  ---------------------------------------------------------------------
  -- STORED DATA
  
  data Store = Store
      {conn :: Connection
      ,path :: FilePath
      ,cache :: Cache
      ,extra :: Var (Map.Map (Either State Patch) (Maybe T.Text))
      }
  
  instance Show Store where
      show Store{..} = show path
  
  newStore :: Bool -> FilePath -> IO Store
  newStore mem path = do
      createDirectoryIfMissing True path
      conn <- create $ if mem then Nothing else Just $ path </> "bake.sqlite"
      cache <- newCache conn
      extra <- newVar Map.empty
      return $ Store conn path cache extra
  
  storeSave :: FilePath -> Store -> IO ()
  storeSave file Store{..} = do
      whenM (doesFileExist file) $ removeFile file
      save conn file
  
  storeSQL :: (ToRow q, FromRow r) => Store -> String -> q -> IO [r]
  storeSQL Store{..} = sqlUnsafe conn
  
  
  ---------------------------------------------------------------------
  -- QUERIES
  
  storePoint :: Store -> Point -> PointInfo
  storePoint Store{..} = snd . unsafePerformIO . cachePoint cache
  
  storeIsPatch :: Store -> Patch -> Bool
  storeIsPatch Store{..} p = unsafePerformIO $ do
      ps <- sqlSelect conn pcPatch [pcPatch %== p]
      return $ ps /= []
  
  storePatch :: Store -> Patch -> PatchInfo
  storePatch Store{..} = snd . unsafePerformIO . cachePatch cache
  
  storeState :: Store -> State -> StateInfo
  storeState Store{..} = snd . unsafePerformIO . cacheState cache
  
  data PP = PP {ppPatch :: Patch, ppReject :: Bool, ppMx :: UTCTime}
  instance FromRow PP where fromRow = PP <$> field <*> field <*> field
  
  storeItemsDate :: Store -> (UTCTime, Maybe UTCTime) -> [Either State Patch]
  storeItemsDate Store{..} (start, end) = unsafePerformIO $ do
  
  #if OPALEYE
      let q :: O.Query (O.Column Patch, O.Column O.PGBool, O.Column O.PGTimestamptz) = proc () -> do
              PCTable{..} <- O.queryTable pcTable__ -< ()
              returnA -< (pcPatch_, O.pgBool True, pcQueue_)
      O.runQuery conn q :: IO [(Patch, Bool, UTCTime)]
  #endif
  
      let ends = words "start delete_ supersede reject plausible merge"
      let str = "SELECT patch, reject IS NOT NULL, max(" ++ intercalate "," ["ifnull(" ++ x ++ ",queue)" | x <- ends] ++ ") AS mx " ++
                "FROM patch WHERE mx > ?" ++
                      (if isJust end then " AND queue < ?"
                       else " OR (delete_ IS NULL AND supersede IS NULL AND reject IS NULL AND merge IS NULL)") ++
                " ORDER BY queue ASC"
      patches :: [PP] <- sqlUnsafe conn str $ start : maybeToList end
  
  #if OPALEYE
      let q :: O.Query (O.Column State, O.Column O.PGTimestamptz) = O.orderBy (O.asc snd) $ proc () -> do
              SATable{..} <- O.queryTable saTable__ -< ()
              O.restrict -< saState_ O../= O.unsafeCoerce (O.pgString "")
              O.restrict -< saCreate_ O..> O.pgUTCTime start
              O.restrict -< maybe (O.pgBool True) (\x -> saCreate_ O..< O.pgUTCTime x) end
              returnA -< (saState_, saCreate_)
      O.runQuery conn q :: IO [(State, UTCTime)]
  #endif
  
      states <- sqlSelect conn (saState, saCreate) $ [orderAsc saCreate, saState %/= toState "", saCreate %> start] ++ [saCreate %< end | Just end <- [end]]
      return $ reverse $ merge states patches
      where
          merge (s:ss) o@(span ppReject -> (reject, p:ps))
              | snd s < ppMx p = Left (fst s) : merge ss o
              | otherwise = map (Right . ppPatch) (reject ++ [p]) ++ merge (s:ss) ps
          merge ss ps = map (Left . fst) ss ++ map (Right . ppPatch) ps
  
  
  storeSkip :: Store -> Map.Map Test String
  storeSkip Store{..} = unsafePerformIO $ cacheSkip cache
  
  storeAlive :: Store -> Set.Set Patch
  storeAlive Store{..} = unsafePerformIO $ cacheAlive cache
  
  storeSupersetPass :: Store -> (State,[Patch]) -> Set.Set Test
  storeSupersetPass Store{..} = unsafePerformIO . cacheSupersetPass cache
  
  
  storeRunList :: Store -> Maybe Client -> Maybe (Maybe Test) -> Maybe State -> [Patch] -> Maybe RunId -> [(RunId, UTCTime, Question, Answer)]
  storeRunList Store{..} client test state patches run = unsafePerformIO $ do
      point <- maybe (return Nothing) (fmap (Just . fst) . cachePoint cache . (, patches)) state
      patches <- if isNothing state && patches /= [] then Just <$> mapM (fmap fst . cachePatch cache) patches else return Nothing
      let filt = [rnClient %== x | Just x <- [client]] ++
                 [rnTest %== x | Just x <- [test]] ++
                 [ptId %==% rnPoint %&& likeP ptPatches (patchIdsSuperset x) | Just x <- [patches]] ++
                 [rnPoint %== x | Just x <- [point]] ++
                 [rnId %== x | Just x <- [run]]
      xs <- sqlSelect conn (rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration) (orderDesc rnStart : limit 1001 : filt)
      forM xs $ \(rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration) -> do
          pt <- cachePointId cache rnPoint
          return (rnId, rnStart, Question pt rnTest 0 rnClient, Answer mempty rnDuration [] rnSuccess)
  
  storeStateList :: Store -> [(State, StateInfo)]
  storeStateList Store{..} = unsafePerformIO $ do
      xs <- sqlSelect conn (saState, saCreate, saPoint, saDuration) [orderDesc saCreate, limit 1000]
      forM xs $ \(sState, sCreate, sPoint, sDuration) -> do
          pt <- maybe (return Nothing) (fmap Just . cachePointId cache) sPoint
          return (sState, StateInfo sCreate pt sDuration)
  
  
  ---------------------------------------------------------------------
  -- UPDATES
  
  data Update
      = IUState State Answer (Maybe Point) -- assumed to be success
      | IUQueue Patch Author
      | IUStart Patch
      | IUDelete Patch
      | IUReject Patch (Maybe Test) Point
      | IUPlausible Patch
      | IUSupersede Patch
      | IUMerge Patch
      | SUAdd Test String
      | SUDel Test
      | PURun UTCTime Question Answer
        deriving Show
  
  instance NFData Update where
      rnf (IUState a b c) = rnf (a,b,c)
      rnf (IUQueue a b) = rnf (a,b)
      rnf (IUStart a) = rnf a
      rnf (IUDelete a) = rnf a
      rnf (IUReject a b c) = rnf (a,b,c)
      rnf (IUPlausible a) = rnf a
      rnf (IUSupersede a) = rnf a
      rnf (IUMerge a) = rnf a
      rnf (SUAdd a b) = rnf (a,b)
      rnf (SUDel a) = rnf a
      rnf (PURun a b c) = rnf (a,b,c)
  
  -- don't inline so GHC can't tell the store is returned unchanged
  {-# NOINLINE storeUpdate #-}
  storeUpdate :: Store -> [Update] -> IO Store
  storeUpdate store xs = do
      -- important so that if the updates depend on the current store they are forced first
      -- the perils of impurity!
      evaluate $ rnf xs
  
      now <- getCurrentTime
      (\f -> foldM f store xs) $ \store x -> do
          f now store x
          cache <- newCache $ conn store
          return store{cache=cache}
      where
          f now Store{..} x = case x of
              IUState s Answer{..} p -> do
                  pt <- maybe (return Nothing) (fmap (Just . fst) . cachePoint cache) p
                  prev <- sqlSelect conn saId [saState %== s]
                  x <- case prev of
                      [] ->
                          sqlInsert conn saTable (s,now,pt,aDuration)
                      Only x:_ -> do
                          sqlUpdate conn [saCreate := now, saPoint := pt, saDuration := aDuration] [saId %== x]
                          return x
                  createDirectoryIfMissing True (path </> show x)
                  bigStringToFile aStdout $ path </> show x </> "update.txt"
              IUQueue p a -> do
                  void $ sqlInsert conn pcTable (p,a,now,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
              IUStart p -> do
                  sqlUpdate conn [pcStart := Just now] [pcPatch %== p]
              IUPlausible p -> do
                  sqlUpdate conn [pcPlausible := Just now] [pcPatch %== p]
              IUMerge p -> do
                  sqlUpdate conn [pcMerge := Just now] [pcPatch %== p]
              IUDelete p -> do
                  sqlUpdate conn [pcDelete := Just now] [pcPatch %== p]
              IUSupersede p -> do
                  sqlUpdate conn [pcSupersede := Just now] [pcPatch %== p]
              IUReject p t pt -> do
                  pt2 <- fst <$> cachePoint cache pt
                  pa <- fst <$> cachePatch cache p
                  Only run:_ <- sqlSelect conn rnId [rnSuccess %== False, rnPoint %== pt2, rnTest %== t]
                  sqlUpdate conn [pcReject := Just now] [pcPatch %== p, pcReject %== Nothing]
                  void $ sqlInsert conn rjTable (pa, t, run)
              SUAdd t msg -> do
                  void $ sqlInsert conn skTable (t, msg)
              SUDel t -> do
                  sqlDelete conn skTable [skTest %== t]
              PURun t Question{..} Answer{..} -> do
                  pt <- fst <$> cachePoint cache qCandidate
                  when (qTest == Nothing) $ do
                      res :: [Only (Maybe Test)] <- sqlSelect conn tsTest [tsPoint %== pt]
                      if null res then do
                          sqlInsert conn tsTable (pt, Nothing)
                          forM_ aTests $ \t -> sqlInsert conn tsTable (pt, Just t)
                      else
                          when (Set.fromList (mapMaybe fromOnly res) /= Set.fromList aTests) $
                              putStrLn $ "Warning: Test disagreement at " ++ show pt ++ ", maybe a changed generator?"
                  x <- sqlInsert conn rnTable (pt,qTest,aSuccess,qClient,t,aDuration)
                  createDirectoryIfMissing True $ path </> show pt
                  bigStringToFile aStdout $ path </> show pt </> show x ++ "-" ++ maybe "Prepare" (safely . fromTest) qTest <.> "txt"
  
  safely :: String -> String
  safely = map f . take 100
      where f x | isAlphaNum x || x `elem` (".-_" :: String) = x
            f x = '_'
  
  
  storeStateFile :: Store -> State -> Maybe String
  storeStateFile Store{..} st = unsafePerformIO $ do
      st <- fst <$> cacheState cache st
      let file = path </> show st </> "update.txt"
      ifM (doesFileExist file) (Just <$> readFile file) (return Nothing)
  
  
  storeRunFile :: Store -> RunId -> Maybe String
  storeRunFile Store{..} run = unsafePerformIO $ do
      [(rPoint, rTest)] <- sqlSelect conn (rnPoint, rnTest) [rnId %== run]
      let file = path </> show rPoint </> show run ++ "-" ++ maybe "Prepare" (safely . fromTest) rTest <.> "txt"
      ifM (doesFileExist file) (Just <$> readFile file) (return Nothing)
  
  
  storeExtraFile :: Store -> Either State Patch -> IO FilePath
  storeExtraFile Store{..} x = (path </>) <$> either (fmap (show . fst) . cacheState cache) (fmap (show . fst) . cachePatch cache) x
  
  
  storeExtra :: Store -> Either State Patch -> Maybe (String, String)
  storeExtra store@Store{..} sp = unsafePerformIO $ do
      prefix <- storeExtraFile store sp
      short <- modifyVar extra $ \mp ->
          case Map.lookup sp mp of
              Just v -> return (mp, v)
              Nothing -> do
                  short <- ifM (doesFileExist $ prefix </> "extra-short.html") (fmap Just $ T.readFile $ prefix </> "extra-short.html") (return Nothing)
                  return (Map.insert sp short mp, short)
      case short of
          Nothing -> return Nothing
          Just short -> do
              long <- unsafeInterleaveIO $ readFile $ prefix </> "extra-long.html"
              return $ Just (T.unpack short, long)
  
  
  storeExtraAdd :: Store -> Either State Patch -> (T.Text, TL.Text) -> IO ()
  storeExtraAdd store@Store{..} sp (short, long) = do
      prefix <- storeExtraFile store sp
      createDirectoryIfMissing True prefix
      T.writeFile (prefix </> "extra-short.html") short
      TL.writeFile (prefix </> "extra-long.html") long
      modifyVar_ extra $ return . Map.insert sp (Just short)
  