@@ -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