<commit_before>{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main, resourcesApp, Widget, WorldId) where
import           Blaze.ByteString.Builder
import           Control.Applicative           (liftA2)
import           Control.Concurrent            (runInUnboundThread)
import           Control.Monad                 (replicateM, forM)
import           Control.Monad.Logger          (runNoLoggingT)
import           Control.Monad.Primitive       (PrimState)
import           Control.Monad.Reader          (ReaderT)
import           Control.Monad.Trans.Resource  (InternalState)
import           Data.Aeson                    (encode)
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Char8 as C8
import           Data.Pool                     (Pool, createPool)
import           Data.Int                      (Int64)
import           Data.IORef                    (newIORef)
import           Data.Function                 (on)
import           Data.List                     (sortBy)
import           Data.Pool                     (withResource)
import           Data.Text                     (Text)
import           Database.Persist              (Key, PersistEntity,
                                                PersistEntityBackend,
                                                PersistStore, get, update,
                                                (=.))
import qualified Database.Persist.Postgresql    as Pg
import Database.Persist.Sql
import           Database.Persist.TH           (mkPersist, mpsGeneric,
                                                persistLowerCase, sqlSettings)
import           Network                       (PortID (PortNumber))
import           Network.HTTP.Types
import           Network.Wai
import qualified Network.Wai.Handler.Warp      as Warp
import           System.Environment            (getArgs)
import           System.IO.Unsafe              (unsafePerformIO)
import qualified System.Random.MWC             as R
import           Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Text.Blaze.Html
import           Yesod
import           Data.Text.Read
import Data.Maybe (fromJust)

mkPersist sqlSettings { mpsGeneric = True } [persistLowerCase|
World sql=World
    randomNumber Int sql=randomnumber
|]

mkPersist sqlSettings { mpsGeneric = True } [persistLowerCase|
Fortune sql=Fortune
    message Text sql=message
|]

instance ToJSON (Entity World) where
  toJSON (Entity wId wRow) = object [
    "id" .= wId
    ,"randomNumber" .= (worldRandomNumber wRow)
    ]

instance ToMarkup FortuneId where
  toMarkup = toMarkup . fromSqlKey

data App = App
    { appGen      :: !(R.Gen (PrimState IO))
    , appDbPool   :: !(Pool Pg.SqlBackend)
    }

-- | Not actually using the non-raw mongoDB.
-- persistent-mongoDB expects a field of '_id', not 'id'
-- mkYesod "App" [parseRoutes|
-- /json               JsonR     GET

-- /db                 DbR       GET
-- /dbs/#Int           DbsR      GET
-- !/dbs/#Text         DbsDefaultR  GET

-- /mongo/raw/db       MongoRawDbR  GET
-- /mongo/raw/dbs/#Int MongoRawDbsR GET
-- !/mongo/raw/dbs/#Text MongoRawDbsDefaultR GET

-- /updates/#Int       UpdatesR     GET
-- !/updates/#Text     UpdatesDefaultR GET

-- /fortunes           FortunesR    GET

-- /plaintext          PlaintextR   GET
-- |]


mkYesod "App" [parseRoutes|
/plaintext          PlaintextR   GET
/db                 DbR          GET
/queries/#Int       QueriesR     GET
!/queries/#Text      DefaultQueriesR     GET
/fortunes           FortunesR    GET
|]

fakeInternalState :: InternalState
fakeInternalState = unsafePerformIO $ newIORef $ error "fakeInternalState forced"
{-# NOINLINE fakeInternalState #-}

instance Yesod App where
    makeSessionBackend _ = return Nothing
    {-# INLINE makeSessionBackend #-}
    shouldLog _ _ _ = False
    {-# INLINE shouldLog #-}
    yesodMiddleware = id
    {-# INLINE yesodMiddleware #-}
    cleanPath _ = Right
    {-# INLINE cleanPath #-}
    yesodWithInternalState _ _ = ($ fakeInternalState)
    {-# INLINE yesodWithInternalState #-}
    maximumContentLength _ _ = Nothing
    {-# INLINE maximumContentLength #-}

-- getJsonR :: Handler ()
-- getJsonR = sendWaiResponse
--          $ responseBuilder
--             status200
--             [("Content-Type", simpleContentType typeJson)]
--          $ copyByteString
--          $ L.toStrict
--          $ encode
--          $ object ["message" .= ("Hello, World!" :: Text)]

runPg dbAction = do
  app <- getYesod
  runSqlPool dbAction (appDbPool app)

getRandomRow = do
  app <- getYesod
  randomNumber <- liftIO $ ((R.uniformR (1, 1000) (appGen app)) :: IO Int)
  let wId = (toSqlKey $ fromIntegral randomNumber) :: WorldId
  get wId >>= \case
    Nothing -> return Nothing
    Just x -> return $ Just (Entity wId x)

getDbR :: Handler Value
getDbR = do
  (runPg getRandomRow) >>= \case
    -- TODO: Throw appropriate HTTP response
    Nothing -> error "This shouldn't be happening"
    Just worldE -> returnJson worldE

getQueriesR :: Int -> Handler Value
getQueriesR cnt = do
  resultMaybe <- (runPg $ forM [1..sanitizedCnt] (\_ -> getRandomRow))
  let result = map fromJust resultMaybe
  returnJson result
  where
    sanitizedCnt
      | cnt<1 = 1
      | cnt>500 = 500
      | otherwise = cnt

getDefaultQueriesR :: Text -> Handler Value
getDefaultQueriesR txt = getQueriesR 1

getFortunesR :: Handler Html
getFortunesR = do
  fortunesFromDb <- runPg $ selectList [] []
  let fortunes = sortBy (compare `on` fortuneMessage . entityVal) $ (Entity (toSqlKey 0) Fortune{fortuneMessage="Additional fortune added at request time."}):fortunesFromDb
  defaultLayout [whamlet|
                      <table>
                        <tr>
                          <th>id
                          <th>message
                        $forall fortune <- fortunes
                          <tr>
                            <td>#{entityKey fortune}
                            <td>#{fortuneMessage $ entityVal fortune}
                          |]
<commit_msg>* setting the page title<commit_after>{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main, resourcesApp, Widget, WorldId) where
import           Blaze.ByteString.Builder
import           Control.Applicative           (liftA2)
import           Control.Concurrent            (runInUnboundThread)
import           Control.Monad                 (replicateM, forM)
import           Control.Monad.Logger          (runNoLoggingT)
import           Control.Monad.Primitive       (PrimState)
import           Control.Monad.Reader          (ReaderT)
import           Control.Monad.Trans.Resource  (InternalState)
import           Data.Aeson                    (encode)
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Char8 as C8
import           Data.Pool                     (Pool, createPool)
import           Data.Int                      (Int64)
import           Data.IORef                    (newIORef)
import           Data.Function                 (on)
import           Data.List                     (sortBy)
import           Data.Pool                     (withResource)
import           Data.Text                     (Text)
import           Database.Persist              (Key, PersistEntity,
                                                PersistEntityBackend,
                                                PersistStore, get, update,
                                                (=.))
import qualified Database.Persist.Postgresql    as Pg
import Database.Persist.Sql
import           Database.Persist.TH           (mkPersist, mpsGeneric,
                                                persistLowerCase, sqlSettings)
import           Network                       (PortID (PortNumber))
import           Network.HTTP.Types
import           Network.Wai
import qualified Network.Wai.Handler.Warp      as Warp
import           System.Environment            (getArgs)
import           System.IO.Unsafe              (unsafePerformIO)
import qualified System.Random.MWC             as R
import           Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Text.Blaze.Html
import           Yesod
import           Data.Text.Read
import Data.Maybe (fromJust)

mkPersist sqlSettings { mpsGeneric = True } [persistLowerCase|
World sql=World
    randomNumber Int sql=randomnumber
|]

mkPersist sqlSettings { mpsGeneric = True } [persistLowerCase|
Fortune sql=Fortune
    message Text sql=message
|]

instance ToJSON (Entity World) where
  toJSON (Entity wId wRow) = object [
    "id" .= wId
    ,"randomNumber" .= (worldRandomNumber wRow)
    ]

instance ToMarkup FortuneId where
  toMarkup = toMarkup . fromSqlKey

data App = App
    { appGen      :: !(R.Gen (PrimState IO))
    , appDbPool   :: !(Pool Pg.SqlBackend)
    }

-- | Not actually using the non-raw mongoDB.
-- persistent-mongoDB expects a field of '_id', not 'id'
-- mkYesod "App" [parseRoutes|
-- /json               JsonR     GET

-- /db                 DbR       GET
-- /dbs/#Int           DbsR      GET
-- !/dbs/#Text         DbsDefaultR  GET

-- /mongo/raw/db       MongoRawDbR  GET
-- /mongo/raw/dbs/#Int MongoRawDbsR GET
-- !/mongo/raw/dbs/#Text MongoRawDbsDefaultR GET

-- /updates/#Int       UpdatesR     GET
-- !/updates/#Text     UpdatesDefaultR GET

-- /fortunes           FortunesR    GET

-- /plaintext          PlaintextR   GET
-- |]


mkYesod "App" [parseRoutes|
/plaintext          PlaintextR   GET
/db                 DbR          GET
/queries/#Int       QueriesR     GET
!/queries/#Text      DefaultQueriesR     GET
/fortunes           FortunesR    GET
|]

fakeInternalState :: InternalState
fakeInternalState = unsafePerformIO $ newIORef $ error "fakeInternalState forced"
{-# NOINLINE fakeInternalState #-}

instance Yesod App where
    makeSessionBackend _ = return Nothing
    {-# INLINE makeSessionBackend #-}
    shouldLog _ _ _ = False
    {-# INLINE shouldLog #-}
    yesodMiddleware = id
    {-# INLINE yesodMiddleware #-}
    cleanPath _ = Right
    {-# INLINE cleanPath #-}
    yesodWithInternalState _ _ = ($ fakeInternalState)
    {-# INLINE yesodWithInternalState #-}
    maximumContentLength _ _ = Nothing
    {-# INLINE maximumContentLength #-}

-- getJsonR :: Handler ()
-- getJsonR = sendWaiResponse
--          $ responseBuilder
--             status200
--             [("Content-Type", simpleContentType typeJson)]
--          $ copyByteString
--          $ L.toStrict
--          $ encode
--          $ object ["message" .= ("Hello, World!" :: Text)]

runPg dbAction = do
  app <- getYesod
  runSqlPool dbAction (appDbPool app)

getRandomRow = do
  app <- getYesod
  randomNumber <- liftIO $ ((R.uniformR (1, 1000) (appGen app)) :: IO Int)
  let wId = (toSqlKey $ fromIntegral randomNumber) :: WorldId
  get wId >>= \case
    Nothing -> return Nothing
    Just x -> return $ Just (Entity wId x)

getDbR :: Handler Value
getDbR = do
  (runPg getRandomRow) >>= \case
    -- TODO: Throw appropriate HTTP response
    Nothing -> error "This shouldn't be happening"
    Just worldE -> returnJson worldE

getQueriesR :: Int -> Handler Value
getQueriesR cnt = do
  resultMaybe <- (runPg $ forM [1..sanitizedCnt] (\_ -> getRandomRow))
  let result = map fromJust resultMaybe
  returnJson result
  where
    sanitizedCnt
      | cnt<1 = 1
      | cnt>500 = 500
      | otherwise = cnt

getDefaultQueriesR :: Text -> Handler Value
getDefaultQueriesR txt = getQueriesR 1

getFortunesR :: Handler Html
getFortunesR = do
  fortunesFromDb <- runPg $ selectList [] []
  let fortunes = sortBy (compare `on` fortuneMessage . entityVal) $ (Entity (toSqlKey 0) Fortune{fortuneMessage="Additional fortune added at request time."}):fortunesFromDb
  defaultLayout $ do
      setTitle "Fortunes"
      [whamlet|
                      <table>
                        <tr>
                          <th>id
                          <th>message
                        $forall fortune <- fortunes
                          <tr>
                            <td>#{entityKey fortune}
                            <td>#{fortuneMessage $ entityVal fortune}
                          |]

{'fraction_non_alphanumeric': 0.09354982869060033, 'fraction_numerical': 0.0037241173841799495, 'mean_word_length': 1.732953388968044, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 41, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5825592', 'n_tokens_mistral': 3916, 'n_tokens_neox': 3819, 'n_words': 947}