git.iko.soy/denis
on master help sign in
Resolved #93
commita8b2e57d4ca22cac2bf1beec8b969cb8d8a899f0 authoriko <ilyakooo0@gmail.com> dateSun 12 May 2019, 19:00 (7 years ago) parentd3d6e79
6 files changed+60−11
compare with master
unifiedsplit
Procfile+1−1 denis/package.yaml+1−5 denis/src/Data/Query.hs+16−1 denis/src/Server/API/Channels.hs+3−1 denis/src/Server/Periodic.hs+29 denis/src/Server/Server.hs+10−3
Procfile+1−1
@@ -1 +1 @@
1−web: denis-exe
1+web: denis-exe +RTS -N -T
denis/package.yaml+1−5
@@ -27,12 +27,9 @@ dependencies:
2727- text
2828- aeson
2929- bytestring
30−# - http-client
31−# - http-client-tls
3230- servant-websockets
3331- websockets
3432- squeal-postgresql
35−# - transformers-base
3633- monad-control
3734- generics-sop
3835- containers
@@ -61,12 +58,11 @@ dependencies:
6158- regex-compat
6259- smtp-mail
6360- mime-mail
64−- periodic
6561- ua-parser
6662- cryptohash-sha512
6763- blaze-html
6864- servant-blaze
69−
65+- random
7066
7167library:
7268 source-dirs: src
denis/src/Data/Query.hs+16−1
@@ -61,7 +61,8 @@ module Data.Query (
6161 updateUser,
6262 UserUpdateRow(..),
6363 killAllTokens,
64− channelCountForUser
64+ channelCountForUser,
65+ pruneAuth
6566 ) where
6667
6768import Squeal.PostgreSQL
@@ -756,6 +757,14 @@ killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
756757killAllTokensQ = deleteFrom_ #tokens
757758 (#tokenUserId .== param @1)
758759
760+pruneDeadTokensQ :: Manipulation Schema '[] '[]
761+pruneDeadTokensQ = deleteFrom_ #tokens
762+ (#tokenExpiryDate .< currentTimestamp)
763+
764+pruneGhostUsersQ :: Manipulation Schema '[] '[]
765+pruneGhostUsersQ = deleteFrom_ #users
766+ (not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) $ from $ table #tokens)
767+
759768-- MARK: FrontEnd Data Structures
760769
761770data UserCreation = UserCreation {
@@ -1056,6 +1065,12 @@ createToken token = void $ manipulateParams createTokenQ token
10561065killAllTokens :: UserId -> StaticPQ ()
10571066killAllTokens = void . manipulateParams killAllTokensQ . Only
10581067
1068+pruneAuth :: StaticPQ ()
1069+pruneAuth = do
1070+ _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
1071+ _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
1072+ return ()
1073+
10591074-- NOTE: Not transactional
10601075validateToken :: Token -> StaticPQ ()
10611076validateToken token = do
denis/src/Server/API/Channels.hs+3−1
@@ -24,12 +24,14 @@ import Server.Query.Pagination
2424import Data.Int
2525import Server.Error
2626
27+type CreateDescription = Description "Creates a new channel\n\nReturns 406 if the channel limit has been exceeded."
28+
2729-- MARK: Implementation
2830
2931type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
3032 "get" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
3133 "getAnonymous" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
32− "create" :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
34+ "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
3335 "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
3436 "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent
3537
denis/src/Server/Periodic.hsnew file+29
@@ -0,0 +1,29 @@
1+module Server.Periodic (
2+ periodically,
3+ seconds,
4+ minutes,
5+ hours
6+ ) where
7+
8+import Control.Monad.IO.Class
9+import Control.Concurrent
10+import System.Random
11+import Control.Monad
12+
13+seconds :: Int
14+seconds = 1000000
15+
16+minutes :: Int
17+minutes = 60 * seconds
18+
19+hours :: Int
20+hours = 60 * minutes
21+
22+periodically :: (MonadIO m) => Int -> IO () -> m ThreadId
23+periodically delay action = liftIO $ do
24+ forkIO $ do
25+ initialDelay <- randomRIO (0, delay)
26+ threadDelay initialDelay
27+ forever $ do
28+ action
29+ threadDelay delay
denis/src/Server/Server.hs+10−3
@@ -17,12 +17,12 @@ import Control.Monad.Reader
1717import Network.Wai.Handler.Warp
1818import Network.HTTP.Types.Method
1919import Server.Logger
20−import Control.Concurrent
2120import Data.Faculty.Parser
2221import Data.Connection
2322import Data.Query
2423import Crypto.RNG
2524import Network.Wai.Middleware.Cors
25+import Server.Periodic
2626
2727getDBString :: IO B.ByteString
2828getDBString = do
@@ -53,7 +53,8 @@ runServer :: IO ()
5353runServer = do
5454 port <- getServerPort
5555 cfg <- getConfig
56− void . forkIO $ updateFaculties cfg
56+ _ <- periodically (1 * hours) $ updateFaculties cfg
57+ _ <- periodically (20 * minutes) $ runDbTask cfg pruneAuth
5758 let ctx = genAuthServerContext $ getPool cfg
5859 (middleLogger, logger) <- mkLogger 500
5960 let serverAPI = mkServerAPI logger
@@ -78,4 +79,10 @@ settings port = setPort port . setServerName "Denis" $ defaultSettings
7879updateFaculties :: Config -> IO ()
7980updateFaculties cfg = do
8081 fs <- getFaculties
81− forM_ fs (runHandler . flip runReaderT cfg . runQerror . updateFaculty)
82+ forM_ fs (runTask cfg . runQerror . updateFaculty)
83+
84+runTask :: Config -> App () -> IO ()
85+runTask cfg = void . runHandler . flip runReaderT cfg
86+
87+runDbTask :: Config -> StaticPQ () -> IO ()
88+runDbTask cfg = runTask cfg . runQsilent