feat: style; prev/next buttons; snippet "support"

go-go.cabal

@@ -70,6 +70,7 @@ library
     , tagsoup
     , text
     , wai
+    , wai-app-static
     , warc
     , warp
   default-language: Haskell2010
@@ -111,6 +112,7 @@ executable go-go-exe
     , tagsoup
     , text
     , wai
+    , wai-app-static
     , warc
     , warp
   default-language: Haskell2010
@@ -151,6 +153,7 @@ executable spider
     , tagsoup
     , text
     , wai
+    , wai-app-static
     , warc
     , warp
   default-language: Haskell2010
@@ -192,6 +195,7 @@ test-suite go-go-test
     , tagsoup
     , text
     , wai
+    , wai-app-static
     , warc
     , warp
   default-language: Haskell2010

package.yaml

@@ -50,6 +50,7 @@ dependencies:
 - servant-lucid
 - lucid
 - http-client
+- wai-app-static
 
 library:
   source-dirs: src

src/Lib.hs

@@ -37,16 +37,16 @@ bad = do
        ]
 
 
-main :: IO ()
-main = do
-  let r = posWords
-
-  putStrLn "GOOD"
-  goods <- good
-  bads <- bad
-  for_ goods $ \(uri, txt) -> print $ runRanker uri txt rankStuff
-  putStrLn "BAD"
-  for_ bads $ \(uri, txt) -> print $ runRanker uri txt rankStuff
+-- main :: IO ()
+-- main = do
+--   let r = posWords
+
+--   putStrLn "GOOD"
+--   goods <- good
+--   bads <- bad
+--   for_ goods $ \(uri, txt) -> print $ runRanker uri txt rankStuff
+--   putStrLn "BAD"
+--   for_ bads $ \(uri, txt) -> print $ runRanker uri txt rankStuff
 
 --   let z = goods <&> \(uri, txt) ->
 --             fmap (invertMap uri . posKeywordsToInv) $ runRanker uri txt posWords

src/Search.hs

@@ -1,16 +1,17 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds         #-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# LANGUAGE TypeOperators     #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveFoldable        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
 
 module Search where
 
@@ -30,7 +31,7 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy as BSL
 import           Data.Containers.ListUtils (nubOrd)
-import           Data.Foldable (for_)
+import           Data.Foldable (for_, toList)
 import           Data.Functor ((<&>))
 import           Data.Functor.Contravariant ((>$<), (>$))
 import           Data.Functor.Identity (Identity)
@@ -60,13 +61,17 @@ import Servant.HTML.Lucid (HTML)
 import qualified Lucid as L
 import Control.Monad.IO.Class (liftIO)
 import Data.String (fromString)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, listToMaybe)
+import Network.Wai.Application.Static (defaultWebAppSettings, ssMaxAge)
+import WaiAppStatic.Types (MaxAge(NoMaxAge))
+import Data.Coerce (coerce)
+import Data.Either (partitionEithers)
 
 
 
 data Search a
   = Terms [a]
-  -- -- | Phrase [a]
+  | Phrase [a]
   -- -- | Or Search Search
   -- -- | Not Keyword
   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
@@ -83,21 +88,45 @@ byDocId m = do
 
 compileSearch :: Search WordId -> Query (Discovery Expr)
 compileSearch (Terms []) = blah
--- compileSearch (Phrase []) = blah
--- compileSearch (Phrase wids) = do
---   byDocId $ distinct $ foldr1 intersect $ do
---     wid <- wids
---     pure $ do
---       w <- each indexSchema
---       where_ $ i_wordId w ==. lit wid
---       pure $ i_docId w
-compileSearch (Terms wids) = distinct $ do
-  byDocId $ distinct $ foldr1 intersect $ do
-    wid <- wids
-    pure $ do
-      w <- each indexSchema
-      where_ $ i_wordId w ==. lit wid
-      pure $ i_docId w
+compileSearch (Phrase []) = blah
+compileSearch (Phrase wids@(w1 : wr)) = do
+  byDocId $ distinct $ do
+    i1 <- each indexSchema
+    where_ $ i_wordId i1 ==. lit w1
+    let p1 = i_position i1
+    distinct $ foldr1 intersect $ do
+      (ix, wid) <- zip [1..] wr
+      pure $ do
+        w <- each indexSchema
+        where_ $ i_wordId w ==. lit wid &&. i_position w ==. p1 + lit ix &&. i_docId w ==. i_docId i1
+        pure $ i_docId w
+compileSearch (Terms wids) =
+  byDocId $
+    distinct $ foldr1 intersect $ do
+      wid <- wids
+      pure $ do
+        w <- each indexSchema
+        where_ $ i_wordId w ==. lit wid
+        pure $ i_docId w
+
+
+getSnippet :: DocId -> [WordId] -> Query (Expr Text)
+getSnippet d [] = do
+  where_ $ lit True ==. lit False
+  pure $ lit ""
+getSnippet d (w : ws) = fmap snd $ orderBy (fst >$< asc) $ do
+  i <- each indexSchema
+  where_ $ i_docId i ==. lit d &&. i_wordId i ==. lit w
+  let p = i_position i
+  j <- each indexSchema
+  where_ $ i_docId i ==. lit d &&. abs (i_position j - p) <=. 5
+  w <- each wordsSchema
+  where_ $ w_wordId w ==. i_wordId j
+  pure (i_position j, w_word w)
+
+
+
+
 
 
 evaluateTerm :: Connection -> Search Keyword -> IO (Search WordId)
@@ -106,11 +135,11 @@ evaluateTerm conn (Terms kws) = do
   let not_in_corpus = S.fromList kws S.\\ S.fromList (fmap (Keyword . w_word) wids)
   print not_in_corpus
   pure $ Terms $ fmap w_wordId wids
--- evaluateTerm conn (Phrase kws) = do
---   Right wids <- flip run conn $ statement () $ select $ getWordIds kws
---   let not_in_corpus = S.fromList kws S.\\ S.fromList (fmap (Keyword . w_word) wids)
---   print not_in_corpus
---   pure $ Phrase $ fmap w_wordId wids
+evaluateTerm conn (Phrase kws) = do
+  Right wids <- flip run conn $ statement () $ select $ getWordIds kws
+  let not_in_corpus = S.fromList kws S.\\ S.fromList (fmap (Keyword . w_word) wids)
+  print not_in_corpus
+  pure $ Phrase $ fmap w_wordId wids
 
 
 
@@ -121,79 +150,82 @@ type TestApi =
         :> QueryParam "q" [Keyword]
         :> QueryParam "p" Int
         :> Get '[HTML] (L.Html ())
+  :<|> Raw
 
 
 instance FromHttpApiData [Keyword] where
   parseQueryParam = Right . fmap Keyword . T.split (== ' ')
 
-testApi :: Proxy TestApi
-testApi = Proxy
-
 home :: L.Html ()
 home =
   L.html_ $ do
-    L.head_ $
+    L.head_ $ do
+      L.link_ [L.rel_ "stylesheet", L.href_ "style.css" ]
       L.title_ "Yo"
     L.body_ $
       L.form_ [ L.action_ "/search", L.method_ "GET" ] $ do
-        L.input_ [ L.type_ "text", L.name_ "q" ]
-        L.input_ [ L.type_ "submit", L.value_ "Search!" ]
+        L.input_ [ L.id_ "query", L.type_ "text", L.name_ "q" ]
+        -- L.input_ [ L.id_ "go", L.type_ "submit", L.value_ "Search!" ]
 
 
 search :: Maybe [Keyword] -> Maybe Int -> Handler (L.Html ())
 search Nothing _ = pure $ "Give me some keywords, punk!"
-search (Just kws) page = do
-  docs <- liftIO $ do
+search (Just kws) mpage = do
+  let q = Terms kws
+
+      pagenum = Prelude.max 0 $ maybe 0 (subtract 1) mpage
+      pagesize :: Num a => a
+      pagesize = 20
+  (cnt, docs, snips) <- liftIO $ do
     Right conn <- acquire connectionSettings
-    swid <- evaluateTerm conn $ Terms kws
-    Right docs <-
+    swid <- evaluateTerm conn q
+    Right (cnt, docs) <- fmap (fmap unzip) $
       flip run conn
         $ statement ()
         $ select
-        $ paginate 20 (fromIntegral $ Prelude.max 0 $ maybe 0 (subtract 1) page)
-        $ orderBy (d_rank >$< desc)
-        $ compileSearch swid
-    pure docs
+        $ paginate pagesize (fromIntegral pagenum)
+        $ let x = orderBy (d_rank >$< desc) $ compileSearch swid
+           in liftA2 (,) (countRows x) x
+    for_ docs $ \doc ->
+      putStrLn $ showQuery $ getSnippet (d_docId doc) $ toList swid
+    -- (_, snips) <- fmap partitionEithers $
+    --   for docs $ \doc ->
+    --     flip run conn
+    --       $ statement ()
+    --       $ select
+    --       $ getSnippet (d_docId doc) $ toList swid
+    let snips = repeat ["Lorem ipsum"]
+    pure (fromMaybe 0 (listToMaybe cnt), docs, snips)
   pure $
     L.html_ $ do
-      L.head_ $
-        L.title_ $ "Search Results for " <> fromString (show kws)
-      L.body_ $
-        for_ docs $ searchResult
-
-searchResult :: Discovery Rel8.Result -> L.Html ()
-searchResult d =
-  L.p_ $ do
-    L.a_ [L.href_ $ d_uri d] $ fromString $ T.unpack $ d_title d
+      L.head_ $ do
+        L.title_ $ "Search Results for " <> fromString (show kws) <> " (" <> fromString (show cnt) <> ")"
+        L.link_ [L.rel_ "stylesheet", L.href_ "results.css" ]
+      L.body_ $ do
+        for_ (zip docs snips) $ uncurry searchResult
+        when (pagenum > 0) $ do
+          L.a_ [L.href_ $ "/search?q=" <> encodeQuery q <> "&p=" <> T.pack (show pagenum)  ] "Prev"
+        when ((pagenum + 1) * pagesize < fromIntegral cnt) $ do
+          L.a_ [L.href_ $ "/search?q=" <> encodeQuery q <> "&p=" <> T.pack (show (pagenum + 2))  ] "Next"
+
+encodeQuery :: Search Keyword -> Text
+encodeQuery (Terms keys) = T.intercalate "+" $ coerce keys
+encodeQuery (Phrase keys) = "\"" <> (T.intercalate "+" $ coerce keys) <> "\""
+
+searchResult :: Discovery Rel8.Result -> [Text] -> L.Html ()
+searchResult d snip =
+  L.div_ [L.class_ "result"] $ do
+    L.span_ [L.class_ "url"] $ L.a_ [L.href_ $ d_uri d] $ fromString $ T.unpack $ d_uri d
     L.br_ []
-    L.a_ [L.href_ $ d_uri d] $ fromString $ T.unpack $ d_uri d
+    L.span_ [L.class_ "title"] $ L.a_ [L.href_ $ d_uri d] $ fromString $ T.unpack $ d_title d
+    L.p_ [L.class_ "snippet"] $ L.toHtml $ T.intercalate " " snip
 
---   where
---     d_title :: Discovery Rel8.Result -> Text
---     d_title = fromMaybe "no title" . flip (runRanker undefined) title . decodeUtf8 . d_data
-
-
--- Server-side handlers.
---
--- There's one handler per endpoint, which, just like in the type
--- that represents the API, are glued together using :<|>.
---
--- Each handler runs in the 'Handler' monad.
 server :: Server TestApi
-server = pure home :<|> search
-
--- Turn the server into a WAI app. 'serve' is provided by servant,
--- more precisely by the Servant.Server module.
-test :: Application
-test = serve testApi server
+server = pure home :<|> search :<|> serveDirectoryWith (defaultWebAppSettings "static") { ssMaxAge = NoMaxAge }
 
--- Run the server.
---
--- 'run' comes from Network.Wai.Handler.Warp
 runTestServer :: W.Port -> IO ()
-runTestServer port = W.run port test
+runTestServer port = W.run port $ serve (Proxy @TestApi) server
 
--- Put this all to work!
 main :: IO ()
 main = runTestServer 8001
 

static/results.css

@@ -0,0 +1,30 @@
+body {
+  background: red;
+}
+
+.result {
+  margin-bottom: 1em;
+  background: white;
+  width: 50em;
+  padding: 1em;
+  font-family: sans;
+}
+
+.url {
+  display: block;
+}
+
+.url a:link, .url a:visited {
+  color: #444;
+  text-decoration: none;
+  font-size: 10pt;
+}
+
+.title {
+  display: block;
+}
+
+.title a {
+  text-decoration: none;
+}
+

static/style.css

@@ -0,0 +1,13 @@
+body {
+  background: red;
+  display: flex;
+  justify-content: center;
+  align-items: center;
+}
+
+#query {
+  font-size: 16pt;
+  width: 40em;
+  padding: 0.5em;
+}
+