a01e757 · denis · git.iko.soy

denis/package.yaml+4−1

compare with master

unifiedsplit

@@ -50,7 +50,10 @@ dependencies:

50- data-default-class

51- fast-logger

52- vector

53−

53+- taggy

54+- unordered-containers

55+- req

56+- data-default

54- lens

57- lens

55

58

56- wai-cors

59- wai-cors

denis/src/Data/Faculty.hsnew file+41

@@ -0,0 +1,41 @@

1+{-# LANGUAGE

2+ DataKinds ,

3+ DeriveGeneric ,

4+ OverloadedLabels,

5+ OverloadedStrings ,

6+ TypeApplications ,

7+ TypeOperators,

8+ OverloadedStrings #-}

9+

10+module Data.Faculty (

11+ Faculty(..)

12+ ) where

13+

14+import qualified Generics.SOP as SOP

15+import qualified GHC.Generics as GHC

16+import Data.Aeson

17+import qualified Data.Text as T

18+import qualified Data.Vector as V

19+

20+data Faculty = Faculty {

21+ facultyName :: T.Text,

22+ facultyURL :: T.Text,

23+ facultyPath :: T.Text,

24+ facultyCampusName :: T.Text,

25+ facultyCampusCode :: T.Text,

26+ facultyTags :: V.Vector T.Text

27+} deriving (GHC.Generic, Show)

28+

29+instance ToJSON Faculty where

30+ toJSON (Faculty name url path campusName campusCode tags) = object [

31+ "name" .= name,

32+ "url" .= url,

33+ "path" .= path,

34+ "campusName" .= campusName,

35+ "campusCode" .= campusCode,

36+ "tags" .= tags

37+ ]

38+

39+instance SOP.Generic Faculty

40+instance SOP.HasDatatypeInfo Faculty

41+

denis/src/Data/Faculty/Parser.hsnew file+81

@@ -0,0 +1,81 @@

1+{-# LANGUAGE

2+ OverloadedStrings,

3+ TupleSections #-}

4+

5+module Data.Faculty.Parser (

6+ getFaculties

7+ ) where

8+

9+import Network.HTTP.Req

10+import qualified Data.Text as T

11+import qualified Data.Text.Lazy as LT

12+import Data.Text.Lazy.Encoding

13+import Text.Taggy.DOM

14+import qualified Data.HashMap.Lazy as HM

15+import Data.Maybe

16+import Data.Faculty

17+import Control.Monad.IO.Class

18+import Data.Default

19+import qualified Data.Vector as V

20+

21+getFaculties :: MonadIO m => m [Faculty]

22+getFaculties = runReq def $ do

23+ campuses <- getCampuses

24+ concat <$> mapM (\c -> getFacultiesForCampus c) campuses

25+

26+sendReq

27+ :: MonadHttp f

28+ => Url scheme

29+ -> f LT.Text

30+sendReq url = decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse mempty

31+

32+getCampuses :: Req [Campus]

33+getCampuses = do

34+ let url = https "www.hse.ru" /: "org" /: "units"

35+ resp <- sendReq url

36+ let dom = parseDOM True resp

37+ return . fromMaybe [] $ do

38+ let els = elements $ dom

39+ campuses <- listToMaybe .

40+ filter (classIs "js-side_filter_content side_filter_content filter_switcher") $ els

41+ sequence . map processCampus . tail . texts' mempty . eltChildren $ campuses

42+ where

43+ processCampus :: (HM.HashMap T.Text T.Text, T.Text) -> Maybe Campus

44+ processCampus (hm, name) = do

45+ code <- HM.lookup "hse-value" hm

46+ return $ Campus name code

47+

48+

49+getFacultiesForCampus :: Campus -> Req [Faculty]

50+getFacultiesForCampus (Campus cName cCode) = do

51+ let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode

52+ resp <- decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse ("ltr" =: (42 :: Int))

53+ let dom = parseDOM True resp

54+ return . catMaybes . map processFaculty . filter (classIs "post person") $ elements dom

55+ where

56+ processFaculty :: Element -> Maybe Faculty

57+ processFaculty el = do

58+ let els = elements [NodeElement el]

59+ nameTag <- listToMaybe . texts' mempty . map (NodeElement) . filter (classIs "link large b") $ els

60+ let name = T.strip . snd $ nameTag

61+ url <- HM.lookup "href" . fst $ nameTag

62+ let tags = map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "with-indent small tag-set") $ els

63+ let path = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "small") $ els

64+ return $ Faculty name url path cName cCode (V.fromList tags)

65+

66+classIs :: T.Text -> Element -> Bool

67+classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs

68+

69+elements :: [Node] -> [Element]

70+elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)

71+elements _ = []

72+

73+texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]

74+texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn

75+texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)

76+texts' _ _ = []

77+

78+data Campus = Campus {

79+ campusName :: T.Text,

80+ campusCode :: T.Text

81+} deriving Show

denis/src/Data/Query.hs+33−3

@@ -40,7 +40,9 @@ module Data.Query (

40 createGroupChat,

41 updateGroupChat,

42 leaveGroupChat,

43− getGroupChatForUser

43+ getGroupChatForUser,

44+ getFaculty,

45+ updateFaculty

44) where

46) where

45

47

46import Squeal.PostgreSQL

48import Squeal.PostgreSQL

@@ -75,6 +77,7 @@ import Data.GroupChat

75import Data.Message

77import Data.Message

76import Server.Query.Dialog

78import Server.Query.Dialog

77import qualified Server.Query.Pagination as P

79import qualified Server.Query.Pagination as P

80+import Data.Faculty

78

81

79-- MARK: Documentation

82-- MARK: Documentation

80

83

@@ -224,6 +227,23 @@ getAllChannelsForUserQ = selectStar $

224 where_ (#namedChannelFullOwner .== param @1) &

227 where_ (#namedChannelFullOwner .== param @1) &

225 orderBy [#namedChannelFullId & Desc]

228 orderBy [#namedChannelFullId & Desc]

226

229

230+updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]

231+updateFacultyQ = insertRow #faculties

232+ (

233+ Set (param @1) `as` #facultyName :*

234+ Set (param @2) `as` #facultyURL :*

235+ Set (param @3) `as` #facultyPath :*

236+ Set (param @4) `as` #facultyCampusName :*

237+ Set (param @5) `as` #facultyCampusCode :*

238+ Set (param @6) `as` #facultyTags

239+ )

240+ (OnConflictDoNothing)

241+ (Returning Nil)

242+

243+getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)

244+getFacultyQ = selectStar (from (table #faculties) &

245+ where_ (#facultyURL .== param @1))

246+

227createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))

247createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))

228createNamedChannelQ = insertRow #channels

248createNamedChannelQ = insertRow #channels

229 (

249 (

@@ -550,6 +570,12 @@ updateChannel uId req = commitedTransactionallyUpdate $ do

550 _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})

570 _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})

551 return ()

571 return ()

552

572

573+getFaculty :: Text -> StaticPQ Faculty

574+getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404

575+

576+updateFaculty :: Faculty -> StaticPQ ()

577+updateFaculty fac = void $ manipulateParams updateFacultyQ fac

578+

553getChannelPosts

579getChannelPosts

554 :: UserId

580 :: UserId

555 -> Maybe PostId

581 -> Maybe PostId

@@ -742,5 +768,9 @@ liftMaybe Nothing _ = pure Nothing

742liftMaybe (Just a) f = f a

768liftMaybe (Just a) f = f a

743

769

744fromMaybe500 :: Maybe a -> StaticPQ a

770fromMaybe500 :: Maybe a -> StaticPQ a

745−fromMaybe500 Nothing = lift $ S.throwError S.err404

771+fromMaybe500 Nothing = lift $ S.throwError S.err500

772+fromMaybe500 (Just a) = return a

773+

774+fromMaybe404 :: Maybe a -> StaticPQ a

775+fromMaybe404 Nothing = lift $ S.throwError S.err404

746−fromMaybe500 (Just a) = return a

776+fromMaybe404 (Just a) = return a

denis/src/Data/Schema.hs+23−1

@@ -140,6 +140,19 @@ type Schema =

140 "messageStorageDestinationUserId" ::: 'NoDef :=> 'Null 'PGint8,

141 "messageStorageBody" ::: 'NoDef :=> 'NotNull (PG (Jsonb (PostElement Message))),

142 "messageStorageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

143+ ]),

144+

145+ "faculties" ::: 'Table (

146+ '[

147+ "pk_faculties" ::: 'PrimaryKey '["facultyName"]

148+ ] :=>

149+ '[

150+ "facultyName" ::: 'NoDef :=> 'NotNull 'PGtext,

151+ "facultyURL" ::: 'NoDef :=> 'NotNull 'PGtext,

152+ "facultyPath" ::: 'NoDef :=> 'NotNull 'PGtext,

153+ "facultyCampusName" ::: 'NoDef :=> 'NotNull 'PGtext,

154+ "facultyCampusCode" ::: 'NoDef :=> 'NotNull 'PGtext,

155+ "facultyTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))

143 ])

156 ])

144

157

145 -- "postsView" ::: 'View (RowPG PostRowResponse)

158 -- "postsView" ::: 'View (RowPG PostRowResponse)

@@ -243,7 +256,16 @@ createTables = createTable #users (

243 foreignKey #messageStorageAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*

256 foreignKey #messageStorageAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*

244 foreignKey #messageStorageDestinationGroupId #groupChats #groupChatId OnDeleteCascade OnUpdateCascade `as` #fk_messages_group :*

257 foreignKey #messageStorageDestinationGroupId #groupChats #groupChatId OnDeleteCascade OnUpdateCascade `as` #fk_messages_group :*

245 foreignKey #messageStorageDestinationUserId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user

258 foreignKey #messageStorageDestinationUserId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user

246− )

259+ ) >>> createTable #faculties (

260+ notNullable text `as` #facultyName :*

261+ notNullable text `as` #facultyURL :*

262+ notNullable text `as` #facultyPath :*

263+ notNullable text `as` #facultyCampusName :*

264+ notNullable text `as` #facultyCampusCode :*

265+ notNullable (vararray text) `as` #facultyTags

266+ ) (

267+ primaryKey #facultyName `as` #pk_faculties

268+ )

247-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])

269-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])

248-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $

270-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $

249-- ((ifThenElse (isNull #rowElementOrd) 1 0) +

271-- ((ifThenElse (isNull #rowElementOrd) 1 0) +

denis/src/Server/Server.hs+13−3

@@ -15,8 +15,12 @@ import Squeal.PostgreSQL.Pool

15import Data.Maybe

16import Control.Monad.Reader

17import Network.Wai.Handler.Warp

18−import Network.HTTP.Types.Method

18+import Network.HTTP.Types.Method

19import Server.Logger

20+import Control.Concurrent

21+import Data.Faculty.Parser

22+import Data.Connection

23+import Data.Query

20

24

21import Network.Wai.Middleware.Cors

25import Network.Wai.Middleware.Cors

22

26

@@ -27,7 +31,7 @@ getDBString = do

27 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL

31 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL

28

32

29getServerPort :: IO Int

33getServerPort :: IO Int

30−getServerPort = maybe 2000 read <$> lookupEnv "PORT"

34+getServerPort = maybe 2000 read <$> lookupEnv "PORT"

31

35

32getConfig :: IO Config

36getConfig :: IO Config

33getConfig = do

37getConfig = do

@@ -39,6 +43,7 @@ runServer :: IO ()

39runServer = do

43runServer = do

40 port <- getServerPort

44 port <- getServerPort

41 cfg <- getConfig

45 cfg <- getConfig

46+ void . forkIO $ updateFaculties cfg

42 let ctx = genAuthServerContext $ getPool cfg

47 let ctx = genAuthServerContext $ getPool cfg

43 (middleLogger, logger) <- mkLogger 100

48 (middleLogger, logger) <- mkLogger 100

44 let serverAPI = mkServerAPI logger

49 let serverAPI = mkServerAPI logger

@@ -58,4 +63,9 @@ policy = CorsResourcePolicy {

58}

63}

59

64

60settings :: Int -> Settings

65settings :: Int -> Settings

61−settings port = setPort port . setServerName "Denis" $ defaultSettings

66+settings port = setPort port . setServerName "Denis" $ defaultSettings

67+

68+updateFaculties :: Config -> IO ()

69+updateFaculties cfg = do

70+ fs <- getFaculties

71+ forM_ fs (runHandler . flip runReaderT cfg . runQerror . updateFaculty)

stack.yaml+2−1

@@ -37,7 +37,8 @@ packages:

37# Dependency packages to be pulled from upstream that are not in the resolver

38# using the same syntax as the packages field.

39# (e.g., acme-missiles-0.3)

40−# extra-deps:

40+extra-deps:

41+- taggy-0.2.1

41# - servant-options-0.1.0.0

42# - servant-options-0.1.0.0

42

43

44