Biblioteka sejmowa crawler

ShadowLibrary/Core.hs

@@ -1,304 +1,302 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
-{-# LANGUAGE GADTs, FlexibleContexts #-}
+{-# LANGUAGE GADTs, FlexibleContexts #-}
-{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
+{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
+
-module ShadowLibrary.Core where
+module ShadowLibrary.Core where
-
+
--- import Database.Persist
+-- import Database.Persist
--- import Database.Persist.TH
+-- import Database.Persist.TH
--- import Database.Persist.Postgresql
+-- import Database.Persist.Postgresql
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Logger (runNoLoggingT)
+import Control.Monad.Logger (runNoLoggingT)
-import Control.Monad.Trans.Resource (runResourceT)
+import Control.Monad.Trans.Resource (runResourceT)
-
+
-import Control.Monad.Reader
+import Control.Monad.Reader
-
+
-import Data.Time
+import Data.Time
-import Data.Time.Calendar
+import Data.Time.Calendar
-import Data.Time.LocalTime
+import Data.Time.LocalTime
-import Data.Time.Zones
+import Data.Time.Zones
-import Data.Time.Zones.All
+import Data.Time.Zones.All
-
+
-import Data.String.Utils (strip)
+import Data.String.Utils (strip)
-import Data.List.Utils as DLU
+import Data.List.Utils as DLU
-
+
-import Text.XML.HXT.Core
+import Text.XML.HXT.Core
-import Network.HTTP
+import Network.HTTP
-import Network.URI
+import Network.URI
-import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Maybe
-import Control.Monad
+import Control.Monad
-import Data.Tree.NTree.TypeDefs
+import Data.Tree.NTree.TypeDefs
-import Data.Maybe
+import Data.Maybe
-import Control.Monad.Trans
+import Control.Monad.Trans
-import Text.XML.HXT.XPath
+import Text.XML.HXT.XPath
--- import Text.XML.HXT.Curl
+import Text.XML.HXT.Curl
-import Text.XML.HXT.HTTP
+import Text.XML.HXT.HTTP
-
+
-import Text.Regex.TDFA
+import Text.Regex.TDFA
-
+
-import Data.List (isInfixOf, intercalate)
+import Data.List (isInfixOf, intercalate)
-
+
-import Data.List.Utils (replace)
+import Data.List.Utils (replace)
-
+
--- import Network.Curl.Opts
+-- import Network.Curl.Opts
-
+
-polishTimeZone = TimeZone {
+polishTimeZone = TimeZone {
-  timeZoneMinutes = 120,
+  timeZoneMinutes = 120,
-  timeZoneSummerOnly = True,
+  timeZoneSummerOnly = True,
-  timeZoneName = ""}
+  timeZoneName = ""}
-
+
-openUrl :: String -> MaybeT IO String
+openUrl :: String -> MaybeT IO String
-openUrl url = case parseURI url of
+openUrl url = case parseURI url of
-    Nothing -> fail ""
+    Nothing -> fail ""
-    Just u  -> liftIO (getResponseBody =<< simpleHTTP (mkRequest GET u))
+    Just u  -> liftIO (getResponseBody =<< simpleHTTP (mkRequest GET u))
-
+
-getWebPage :: String -> IO (IOSArrow XmlTree (NTree XNode))
+getWebPage :: String -> IO (IOSArrow XmlTree (NTree XNode))
-getWebPage url = do
+getWebPage url = do
-  contents <- runMaybeT $ openUrl url
+  contents <- runMaybeT $ openUrl url
-  return $ readString [withParseHTML yes, withWarnings no] (fromMaybe "" contents)
+  return $ readString [withParseHTML yes, withWarnings no] (fromMaybe "" contents)
-
+
-downloadDocument = readFromDocument [withParseHTML yes,
+downloadDocument = readFromDocument [withParseHTML yes,
-                                     withWarnings no,
+                                     withWarnings no,
-                                     withEncodingErrors no,
+                                     withEncodingErrors no,
-                                     withPreserveComment yes,
+                                     withPreserveComment yes,
-                                     withStrictInput yes,
+                                     withStrictInput yes,
-                                     withHTTP []
+                                     withCurl [("curl--user-agent","AMU Digital Libraries Indexing Agent")]
---                                     withCurl [("curl--user-agent","AMU Digital Libraries Indexing Agent")]
+                                    ]
-                                    ]
+
-
+downloadDocumentWithEncoding enc = readFromDocument [withParseHTML yes,
-downloadDocumentWithEncoding enc = readFromDocument [withParseHTML yes,
+                                                     withWarnings no,
-                                                     withWarnings no,
+                                                     withEncodingErrors no,
-                                                     withEncodingErrors no,
+                                                     withPreserveComment yes,
-                                                     withPreserveComment yes,
+                                                     withInputEncoding enc,
-                                                     withInputEncoding enc,
+                                                     withCurl []]
-					             withHTTP []]		
+
---                                                     withCurl []]
+downloadXmlDocument = readFromDocument [withWarnings no,
-
+                                        withEncodingErrors no,
-downloadXmlDocument = readFromDocument [withWarnings no,
+					withHTTP []]
-                                        withEncodingErrors no,
+--                                        withCurl [] ]
-					withHTTP []]
+
---                                        withCurl [] ]
+
-
+data ShadowLibrary = ShadowLibrary { logoUrl :: Maybe String,
-
+                                     lname :: String,
-data ShadowLibrary = ShadowLibrary { logoUrl :: Maybe String,
+                                     abbrev :: String,
-                                     lname :: String,
+                                     webpage :: String,
-                                     abbrev :: String,
+                                     lLevel :: Int }
-                                     webpage :: String,
+
-                                     lLevel :: Int }
+
-
+data ShadowItem = ShadowItem {
-
+  url :: Maybe String,
-data ShadowItem = ShadowItem {
+  title :: String,
-  url :: Maybe String,
+  itype :: String,
-  title :: String,
+  originalDate :: Maybe String,
-  itype :: String,
+  creator :: Maybe String,
-  originalDate :: Maybe String,
+  format :: Maybe String,
-  creator :: Maybe String,
+  lang :: Maybe String,
-  format :: Maybe String,
+  finalUrl :: String,
-  lang :: Maybe String,
+  description :: Maybe String
-  finalUrl :: String,
+  } deriving (Show)
-  description :: Maybe String
+
-  } deriving (Show)
+defaultShadowItem url title = ShadowItem {
-
+  url = Just url,
-defaultShadowItem url title = ShadowItem {
+  title = title,
-  url = Just url,
+  itype = "periodical",
-  title = title,
+  originalDate = Nothing,
-  itype = "periodical",
+  creator = Nothing,
-  originalDate = Nothing,
+  format = Just "pdf",
-  creator = Nothing,
+  lang = Just "pol",
-  format = Just "pdf",
+  finalUrl = url,
-  lang = Just "pol",
+  description = Nothing }
-  finalUrl = url,
+
-  description = Nothing }
+
-
+getDuration :: Maybe String -> (Maybe UTCTime, Maybe UTCTime)
-
+getDuration Nothing = (Nothing, Nothing)
-getDuration :: Maybe String -> (Maybe UTCTime, Maybe UTCTime)
+getDuration (Just date) =
-getDuration Nothing = (Nothing, Nothing)
+  case date =~~ ("^(1[6789]|20)[0-9][0-9]$" :: String) of
-getDuration (Just date) =
+    Just year -> (Just (yearStart year), Just (yearEnd year))
-  case date =~~ ("^(1[6789]|20)[0-9][0-9]$" :: String) of
+    otherwise ->
-    Just year -> (Just (yearStart year), Just (yearEnd year))
+      case date =~~ ("^((1[789]|20)[0-9][0-9])-(0[1-9]|1[0-2])$" :: String) :: Maybe [[String]] of
-    otherwise ->
+        Just [[_, year, _, month]] -> (Just (monthStart year month), Just (monthEnd year month))
-      case date =~~ ("^((1[789]|20)[0-9][0-9])-(0[1-9]|1[0-2])$" :: String) :: Maybe [[String]] of
+        otherwise ->
-        Just [[_, year, _, month]] -> (Just (monthStart year month), Just (monthEnd year month))
+          case date =~~ ("^((1[789]|20)[0-9][0-9])-(0[1-9]|1[0-2])-(0[1-9]|[12][0-9]|3[01])$" :: String) :: Maybe [[String]] of
-        otherwise ->
+            Just [[_, year, _, month, day]] -> (Just (dayStart year month day), Just (dayEnd year month day))
-          case date =~~ ("^((1[789]|20)[0-9][0-9])-(0[1-9]|1[0-2])-(0[1-9]|[12][0-9]|3[01])$" :: String) :: Maybe [[String]] of
+            otherwise ->
-            Just [[_, year, _, month, day]] -> (Just (dayStart year month day), Just (dayEnd year month day))
+              case date =~~ ("^((1[789]|20)[0-9][0-9])-((1[789]|20)[0-9][0-9])$" :: String) :: Maybe [[String]] of
-            otherwise ->
+                Just [[_, yearb, _, yeare, _]] -> (Just (yearStart yearb), Just (yearEnd yeare))
-              case date =~~ ("^((1[789]|20)[0-9][0-9])-((1[789]|20)[0-9][0-9])$" :: String) :: Maybe [[String]] of
+                otherwise -> (Nothing, Nothing)
-                Just [[_, yearb, _, yeare, _]] -> (Just (yearStart yearb), Just (yearEnd yeare))
+  where
-                otherwise -> (Nothing, Nothing)
+    yearAsInteger year = (read year) :: Integer
-  where
+    monthAsInt month = (read month) :: Int
-    yearAsInteger year = (read year) :: Integer
+    dayAsInt day = (read day) :: Int
-    monthAsInt month = (read month) :: Int
+    yearStart year = localTimeToTimeStamp $ LocalTime {
-    dayAsInt day = (read day) :: Int
+      localDay = fromGregorian (yearAsInteger year) 1 1,
-    yearStart year = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = midnight }
-      localDay = fromGregorian (yearAsInteger year) 1 1,
+    yearEnd year = localTimeToTimeStamp $ LocalTime {
-      localTimeOfDay = midnight }
+      localDay = fromGregorian (yearAsInteger year) 12 31,
-    yearEnd year = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = lastSecond }
-      localDay = fromGregorian (yearAsInteger year) 12 31,
+    monthStart year month = localTimeToTimeStamp $ LocalTime {
-      localTimeOfDay = lastSecond }
+      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) 1,
-    monthStart year month = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = midnight }
-      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) 1,
+    monthEnd year month = localTimeToTimeStamp $ LocalTime {
-      localTimeOfDay = midnight }
+      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) 31,
-    monthEnd year month = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = lastSecond }
-      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) 31,
+    dayStart year month day = localTimeToTimeStamp $ LocalTime {
-      localTimeOfDay = lastSecond }
+      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) (dayAsInt day),
-    dayStart year month day = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = midnight }
-      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) (dayAsInt day),
+    dayEnd year month day = localTimeToTimeStamp $ LocalTime {
-      localTimeOfDay = midnight }
+      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) (dayAsInt day),
-    dayEnd year month day = localTimeToTimeStamp $ LocalTime {
+      localTimeOfDay = lastSecond }
-      localDay = fromGregorian (yearAsInteger year) (monthAsInt month) (dayAsInt day),
+    lastSecond = TimeOfDay {todHour = 23, todMin = 59, todSec = 59 }
-      localTimeOfDay = lastSecond }
+
-    lastSecond = TimeOfDay {todHour = 23, todMin = 59, todSec = 59 }
+localTimeToTimeStamp ltime = localTimeToUTCTZ (tzByLabel Europe__Warsaw) ltime
-
+
-localTimeToTimeStamp ltime = localTimeToUTCTZ (tzByLabel Europe__Warsaw) ltime
+--  zonedTimeToUTC $ ZonedTime {
-
+--  zonedTimeToLocalTime = ltime,
---  zonedTimeToUTC $ ZonedTime {
+--  zonedTimeZone = timeZoneForUTCTime Europe__Warsaw }
---  zonedTimeToLocalTime = ltime,
+
---  zonedTimeZone = timeZoneForUTCTime Europe__Warsaw }
+extractLinks xpathCondition = (downloadDocument &&& this)
-
+                              >>> first (getXPathTrees xpathCondition
-extractLinks xpathCondition = (downloadDocument &&& this)
+                                         >>> getAttrValue "href")
-                              >>> first (getXPathTrees xpathCondition
+                              >>> expandURIFixed
-                                         >>> getAttrValue "href")
+
-                              >>> expandURIFixed
+extractLinksGeneralized xpathCondition attr = (downloadDocument &&& this)
-
+                                              >>> first (getXPathTrees xpathCondition
-extractLinksGeneralized xpathCondition attr = (downloadDocument &&& this)
+                                                         >>> getAttrValue attr)
-                                              >>> first (getXPathTrees xpathCondition
+                                              >>> expandURIFixed
-                                                         >>> getAttrValue attr)
+
-                                              >>> expandURIFixed
+rotateSecTh ((a, b), c) = ((a, c), b)
-
+
-rotateSecTh ((a, b), c) = ((a, c), b)
+extractLinksWithText xpathCondition = (downloadDocument &&& this)
-
+                                      >>> first (getXPathTrees xpathCondition
-extractLinksWithText xpathCondition = (downloadDocument &&& this)
+                                                 >>> (getAttrValue "href"
-                                      >>> first (getXPathTrees xpathCondition
+                                                      &&& (listA (deep isText >>> getText)
-                                                 >>> (getAttrValue "href"
+                                                           >>> arr (intercalate " "))))
-                                                      &&& (listA (deep isText >>> getText)
+                                      >>> arr rotateSecTh
-                                                           >>> arr (intercalate " "))))
+                                      >>> first expandURIFixed
-                                      >>> arr rotateSecTh
+
-                                      >>> first expandURIFixed
+extractLinksWithTitle xpathCondition = (downloadDocument &&& this)
-
+                                       >>> first (getXPathTrees xpathCondition
-extractLinksWithTitle xpathCondition = (downloadDocument &&& this)
+                                                  >>> (getAttrValue "href"
-                                       >>> first (getXPathTrees xpathCondition
+                                                       &&& getAttrValue "title"))
-                                                  >>> (getAttrValue "href"
+                                       >>> arr rotateSecTh
-                                                       &&& getAttrValue "title"))
+                                       >>> first expandURIFixed
-                                       >>> arr rotateSecTh
+
-                                       >>> first expandURIFixed
+urlPreFixer = arr (Data.List.Utils.replace "[" stupidLeftBracketMarker . Data.List.Utils.replace "]" stupidRightBracketMarker)
-
+urlPostFixer = arr (Data.List.Utils.replace stupidLeftBracketMarker "%5B" . Data.List.Utils.replace stupidRightBracketMarker "%5D")
-urlPreFixer = arr (Data.List.Utils.replace "[" stupidLeftBracketMarker . Data.List.Utils.replace "]" stupidRightBracketMarker)
+
-urlPostFixer = arr (Data.List.Utils.replace stupidLeftBracketMarker "%5B" . Data.List.Utils.replace stupidRightBracketMarker "%5D")
+stupidLeftBracketMarker = "ddsfdfdfdfgfgfrrtrtrrtr"
-
+stupidRightBracketMarker = "wqweweerererrtrtrtrtrtr"
-stupidLeftBracketMarker = "ddsfdfdfdfgfgfrrtrtrrtr"
+
-stupidRightBracketMarker = "wqweweerererrtrtrtrtrtr"
+expandURIFixed = (urlPreFixer *** urlPreFixer) >>> expandURI >>> urlPostFixer
-
+
-expandURIFixed = (urlPreFixer *** urlPreFixer) >>> expandURI >>> urlPostFixer
+
-
+extractText = (listA (deep isText >>> getText)
-
+               >>> arr (intercalate " "))
-extractText = (listA (deep isText >>> getText)
+
-               >>> arr (intercalate " "))
+loopNext extract xpathConditionForNext = initialStep
-
+                                         >>> loopNextCore extract xpathConditionForNext
-loopNext extract xpathConditionForNext = initialStep
+                                         >>> arr fst
-                                         >>> loopNextCore extract xpathConditionForNext
+                                         >>> unlistA
-                                         >>> arr fst
+
-                                         >>> unlistA
+initialList :: [(String, a)]
-
+initialList = []
-initialList :: [(String, a)]
+
-initialList = []
+initialStep = arr (const initialList) &&& this
-
+
-initialStep = arr (const initialList) &&& this
+
-
+loopNextCore extract xpathConditionForNext = second
-
+                                               (listA extract &&& extractNext xpathConditionForNext)
-loopNextCore extract xpathConditionForNext = second
+                                             >>> arr expandList
-                                               (listA extract &&& extractNext xpathConditionForNext)
+                                             >>> ifP (nextFound)
-                                             >>> arr expandList
+                                                    (second (arr fromJust >>> (downloadDocument &&& this))
-                                             >>> ifP (nextFound)
+                                                     >>> loopNextCore extract xpathConditionForNext)
-                                                    (second (arr fromJust >>> (downloadDocument &&& this))
+                                                    (this)
-                                                     >>> loopNextCore extract xpathConditionForNext)
+
-                                                    (this)
+nextFound :: ([(String,a)], Maybe String) -> Bool
-
+nextFound (_, Just _) = True
-nextFound :: ([(String,a)], Maybe String) -> Bool
+nextFound (_, Nothing) = False
-nextFound (_, Just _) = True
+
-nextFound (_, Nothing) = False
+
-
+expandList (l, (e, n)) = (l ++ e, n)
-
+
-expandList (l, (e, n)) = (l ++ e, n)
+extractNext xpathConditionForNext = listA
-
+                                          (first (getXPathTrees ("(" ++ xpathConditionForNext ++ ")[1]")
-extractNext xpathConditionForNext = listA
+                                                  >>> getAttrValue "href")
-                                          (first (getXPathTrees ("(" ++ xpathConditionForNext ++ ")[1]")
+                                           >>> expandURIFixed)
-                                                  >>> getAttrValue "href")
+                                    >>> arr listToMaybe
-                                           >>> expandURIFixed)
+
-                                    >>> arr listToMaybe
+
-
+extractFormat :: String -> Maybe String
-
+extractFormat finalUrl
-extractFormat :: String -> Maybe String
+  | ".gif" `isInfixOf` finalUrl = Just "gif"
-extractFormat finalUrl
+  | ".jpg" `isInfixOf` finalUrl = Just "jpg"
-  | ".gif" `isInfixOf` finalUrl = Just "gif"
+  | ".djvu" `isInfixOf` finalUrl = Just "djvu"
-  | ".jpg" `isInfixOf` finalUrl = Just "jpg"
+  | ".pdf" `isInfixOf` finalUrl = Just "pdf"
-  | ".djvu" `isInfixOf` finalUrl = Just "djvu"
+  | ".doc" `isInfixOf` finalUrl = Just "doc"
-  | ".pdf" `isInfixOf` finalUrl = Just "pdf"
+  | otherwise = Nothing
-  | ".doc" `isInfixOf` finalUrl = Just "doc"
+
-  | otherwise = Nothing
+
-
+
-
+baseMonthNameToNumber :: String -> Maybe String
-
+baseMonthNameToNumber "styczeń"     = Just "01"
-baseMonthNameToNumber :: String -> Maybe String
+baseMonthNameToNumber "styczen"     = Just "01"
-baseMonthNameToNumber "styczeń"     = Just "01"
+baseMonthNameToNumber "stycznia"     = Just "01"
-baseMonthNameToNumber "styczen"     = Just "01"
+baseMonthNameToNumber "luty"        = Just "02"
-baseMonthNameToNumber "stycznia"     = Just "01"
+baseMonthNameToNumber "lutego"        = Just "02"
-baseMonthNameToNumber "luty"        = Just "02"
+baseMonthNameToNumber "marzec"      = Just "03"
-baseMonthNameToNumber "lutego"        = Just "02"
+baseMonthNameToNumber "marca"      = Just "03"
-baseMonthNameToNumber "marzec"      = Just "03"
+baseMonthNameToNumber "kwiecień"    = Just "04"
-baseMonthNameToNumber "marca"      = Just "03"
+baseMonthNameToNumber "kwiecien"    = Just "04"
-baseMonthNameToNumber "kwiecień"    = Just "04"
+baseMonthNameToNumber "kwietnia"    = Just "04"
-baseMonthNameToNumber "kwiecien"    = Just "04"
+baseMonthNameToNumber "maj"         = Just "05"
-baseMonthNameToNumber "kwietnia"    = Just "04"
+baseMonthNameToNumber "maja"         = Just "05"
-baseMonthNameToNumber "maj"         = Just "05"
+baseMonthNameToNumber "czerwiec"    = Just "06"
-baseMonthNameToNumber "maja"         = Just "05"
+baseMonthNameToNumber "czeerwiec"    = Just "06"
-baseMonthNameToNumber "czerwiec"    = Just "06"
+baseMonthNameToNumber "czerwca"    = Just "06"
-baseMonthNameToNumber "czeerwiec"    = Just "06"
+baseMonthNameToNumber "lipiec"      = Just "07"
-baseMonthNameToNumber "czerwca"    = Just "06"
+baseMonthNameToNumber "lipca"      = Just "07"
-baseMonthNameToNumber "lipiec"      = Just "07"
+baseMonthNameToNumber "sierpień"    = Just "08"
-baseMonthNameToNumber "lipca"      = Just "07"
+baseMonthNameToNumber "sierpien"    = Just "08"
-baseMonthNameToNumber "sierpień"    = Just "08"
+baseMonthNameToNumber "sierpnia"    = Just "08"
-baseMonthNameToNumber "sierpien"    = Just "08"
+baseMonthNameToNumber "wrzesień"    = Just "09"
-baseMonthNameToNumber "sierpnia"    = Just "08"
+baseMonthNameToNumber "wrzesien"    = Just "09"
-baseMonthNameToNumber "wrzesień"    = Just "09"
+baseMonthNameToNumber "września"    = Just "09"
-baseMonthNameToNumber "wrzesien"    = Just "09"
+baseMonthNameToNumber "wrzesnia"    = Just "09"
-baseMonthNameToNumber "września"    = Just "09"
+baseMonthNameToNumber "październik" = Just "10"
-baseMonthNameToNumber "wrzesnia"    = Just "09"
+baseMonthNameToNumber "pażdziernik" = Just "10"
-baseMonthNameToNumber "październik" = Just "10"
+baseMonthNameToNumber "pazdziernik" = Just "10"
-baseMonthNameToNumber "pażdziernik" = Just "10"
+baseMonthNameToNumber "października" = Just "10"
-baseMonthNameToNumber "pazdziernik" = Just "10"
+baseMonthNameToNumber "pazdziernika" = Just "10"
-baseMonthNameToNumber "października" = Just "10"
+baseMonthNameToNumber "listopad"    = Just "11"
-baseMonthNameToNumber "pazdziernika" = Just "10"
+baseMonthNameToNumber "listopada"    = Just "11"
-baseMonthNameToNumber "listopad"    = Just "11"
+baseMonthNameToNumber "grudzień"    = Just "12"
-baseMonthNameToNumber "listopada"    = Just "11"
+baseMonthNameToNumber "grudzien"    = Just "12"
-baseMonthNameToNumber "grudzień"    = Just "12"
+baseMonthNameToNumber "grudnia"    = Just "12"
-baseMonthNameToNumber "grudzien"    = Just "12"
+baseMonthNameToNumber "jesien"    = Just "10"
-baseMonthNameToNumber "grudnia"    = Just "12"
+baseMonthNameToNumber _             = Nothing
-baseMonthNameToNumber "jesien"    = Just "10"
+
-baseMonthNameToNumber _             = Nothing
+extractYear :: String -> Maybe String
-
+extractYear n =
-extractYear :: String -> Maybe String
+  case n =~~ ("(1[6789]|20)[0-9][0-9]" :: String) of
-extractYear n =
+    Just year -> Just year
-  case n =~~ ("(1[6789]|20)[0-9][0-9]" :: String) of
+    otherwise -> Nothing
-    Just year -> Just year
+
-    otherwise -> Nothing
+
-
+joinAlts :: [String] -> String
-
+joinAlts = intercalate " // "
-joinAlts :: [String] -> String
+
-joinAlts = intercalate " // "
+clean = arr (DLU.replace "\n" "")
-
+        >>> arr strip
-clean = arr (DLU.replace "\n" "")
+
-        >>> arr strip
+extractItems shadowLibrary start extractor = do
-
+  page <- getWebPage start
-extractItems shadowLibrary start extractor = do
+  items <- runX $ extractor start page
-  page <- getWebPage start
+--  insertIntoDatabase shadowLibrary items
-  items <- runX $ extractor start page
+  putStrLn (show items)
---  insertIntoDatabase shadowLibrary items
+
-  putStrLn (show items)
+extractItemsStartingFromUrl shadowLibrary start extractor = do
-
+  items <- runX $ (arr (const start) >>> setTraceLevel 1 >>> extractor)
-extractItemsStartingFromUrl shadowLibrary start extractor = do
+--  insertIntoDatabase shadowLibrary items
-  items <- runX $ (arr (const start) >>> setTraceLevel 1 >>> extractor)
+  mapM_ (putStrLn . show) items
---  insertIntoDatabase shadowLibrary items
-  mapM_ (putStrLn . show) items

app/bibliotekasejmowa.hs

@@ -0,0 +1,46 @@
+
+{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
+import ShadowLibrary.Core
+
+import Text.XML.HXT.Core
+import Text.XML.HXT.XPath
+import Text.XML.HXT.Curl
+import Data.List
+import Data.List.Utils (replace)
+
+import Text.Regex.Posix
+import Text.Printf
+
+extractAllPDFs = extractLinksWithText "/html/body/table[4]/tbody/tr[7]/td[2]/a"
+
+extractRecords = extractLinksWithText "//table[3]//a"
+                 >>> first (extractLinksWithText "//table[3]//a"
+                           >>> first (extractLinksWithText "//table[4]//a"
+                                     >>> first (extractAllPDFs
+                                               >>> first(arr $ (drop 23 ) . init . init . init))))
+
+toShadowItem :: ((((String, String), String), String), String) -> ShadowItem
+toShadowItem ((((url, typeName), articleTitle), _), category) =
+  (defaultShadowItem url title) {
+    originalDate = Just date,
+    itype = "periodical",
+    format = Just "pdf",
+    finalUrl = url
+    }
+  where title = "Biblioteka Sejmowa " ++ category ++ " " ++ typeName ++ " " ++ articleTitle
+        date = getDate articleTitle
+
+getDate url =
+  case url =~~ "/(19[0-9][0-9]|20[0-9][0-9])/" :: Maybe [[String]] of
+    Just [[_, year]] -> year
+    otherwise -> error $ "unexpected url: " ++ url
+
+
+main = do
+    let start = "https://bs.sejm.gov.pl/F/?con_lng=POL&func=file&file_name=find-nowe&local_base=ars01"
+    let shadowLibrary = ShadowLibrary {logoUrl=Nothing,
+                                       lname="Biblioteka Sejmowa",
+                                       abbrev="BiblSejm",
+                                       lLevel=0,
+                                       webpage=start}
+    extractItemsStartingFromUrl shadowLibrary start (extractRecords >>> arr toShadowItem)

shadow-library.cabal

@@ -2,11 +2,11 @@ name:                shadow-library
 version:             0.1.0.0
 synopsis:            Initial project template from stack
 description:         Please see README.md
-homepage:            http://github.com/name/project
+homepage:            https://git.wmi.amu.edu.pl/s444409/twilight-library
 license:             Proprietary
 license-file:        LICENSE
-author:              Your name here
+author:              Marcin Kostrzewski
-maintainer:          your.address@example.com
+maintainer:          markos34@st.amu.edu.pl
 -- copyright:
 category:            Web
 build-type:          Simple
@@ -21,6 +21,7 @@ library
                      , hxt
                      , hxt-http
                      , hxt-xpath
+                     , hxt-curl
                      , MissingH
                      , monad-logger
                      , mtl
@@ -54,12 +55,26 @@ executable almanachmuszyny
    build-depends:       base
                       , hxt
                       , hxt-xpath
+                      , hxt-curl
                       , MissingH
                       , regex-posix
                       , shadow-library
    default-language:    Haskell2010
 
+executable bibliotekasejmowa
+  hs-source-dirs:      app
+  main-is:             bibliotekasejmowa.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , hxt
+                     , hxt-xpath
+                     , hxt-curl
+                     , MissingH
+                     , regex-posix
+                     , shadow-library
+  default-language:    Haskell2010
+
 
 source-repository head
   type:     git
-  location: https://github.com/name/project
+  location: https://git.wmi.amu.edu.pl/s444409/twilight-library

stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: hxt-xpath-9.1.2.2@sha256:9cd590ae93a04573db8f90fa4094625ebd97dded45da7667c577ce6b38a42900,1999
+    pantry-tree:
+      size: 2225
+      sha256: aee2f75974e868ff429b8ff349a29667536c60397098f5dfedc968d1951511bb
+  original:
+    hackage: hxt-xpath-9.1.2.2
+snapshots:
+- completed:
+    size: 507596
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/9.yaml
+    sha256: 42f472dbf06482da1b3319241f3e3b3593a45bd7d4f537d2789f21386b9b2ad3
+  original: lts-11.9