aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-12-22 20:31:31 +03:00
Code Issues Projects Releases Wiki Activity

Migrate to GHC 8.4

Browse Source
This commit is contained in:
Artyom Kazak 2018-09-02 00:03:48 +02:00
parent 07b381567f
commit cdc4bd74fe
33 changed files with 302 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
guide.cabal
View File

@ -11,7 +11,7 @@ author: Artyom
maintainer: yom@artyom.me
-- copyright:
category: Web
tested-with: GHC == 8.2.2
tested-with: GHC == 8.4
build-type: Custom
extra-source-files:
CHANGELOG.md
@ -85,13 +85,14 @@ library
Guide.Routes
other-modules:
Imports
To
build-depends: Spock
, Spock-digestive
, Spock-lucid == 0.4.*
, acid-state == 0.14.*
, aeson == 1.2.*
, Spock-lucid
, acid-state
, aeson
, aeson-pretty
, base == 4.10.*
, base < 5
, base-prelude
, bytestring
, cereal
@ -110,10 +111,10 @@ library
, feed == 1.0.*
, filemanip == 0.3.6.*
, filepath
, fmt == 0.4.*
, fmt
, focus
, friendly-time == 0.4.*
, fsnotify == 0.2.*
, fsnotify
, hashable
, haskell-src-meta
, http-api-data
@ -139,7 +140,7 @@ library
, safecopy-migrate == 0.2.*
, say
, scrypt
, servant-generic
, servant
, servant-server
, servant-swagger
, servant-swagger-ui-redoc
@ -152,7 +153,6 @@ library
, stm-containers >= 0.2.14 && < 0.3
, template-haskell
, text
, text-all >= 0.4.1.0 && < 0.5
, time >= 1.5
, transformers
, uniplate
@ -210,7 +210,7 @@ test-suite tests
, quickcheck-text < 0.2
, slave-thread
, tagsoup < 1
, text-all
, text
, transformers
, webdriver >= 0.8.4 && < 0.9
hs-source-dirs: tests

7
src/Guide/Api/Error.hs
View File

@ -17,7 +17,6 @@ import GHC.TypeLits
import Servant
import Servant.Swagger
import Data.Swagger
import qualified Data.Text.All as T
-- Taken from https://github.com/haskell-servant/servant-swagger/issues/59
@ -34,11 +33,11 @@ instance
code = natVal (Proxy :: Proxy code)
desc = symbolVal (Proxy :: Proxy desc)
responseSchema = mempty
& description .~ T.toStrict desc
& description .~ toText desc
instance HasLink sub => HasLink (ErrorResponse code desc :> sub) where
type MkLink (ErrorResponse code desc :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
type MkLink (ErrorResponse code desc :> sub) a = MkLink sub a
toLink f _ l = toLink f (Proxy :: Proxy sub) l
instance HasServer api ctx => HasServer (ErrorResponse code desc :> api) ctx where
type ServerT (ErrorResponse code desc :> api) m = ServerT api m

4
src/Guide/Api/Methods.hs
View File

@ -10,8 +10,8 @@ import Imports
import Servant
import Data.Acid as Acid
import qualified Data.Text.All as T
import Data.Text.All (Text)
import qualified Data.Text as T
import Data.Text (Text)
import Guide.Types
import Guide.State

3
src/Guide/Api/Server.hs
View File

@ -14,7 +14,8 @@ import Imports
import Data.Acid as Acid
import Servant
import Servant.Generic
import Servant.API.Generic
import Servant.Server.Generic
import Servant.Swagger
import Servant.Swagger.UI.ReDoc
import Data.Swagger.Lens

17
src/Guide/Api/Types.hs
View File

@ -34,10 +34,9 @@ module Guide.Api.Types
import Imports
import qualified Data.Aeson as A
import qualified Data.Text.All as T
import Lucid (toHtml, renderText)
import Servant
import Servant.Generic
import Servant.API.Generic
import Data.Swagger as S
import Guide.Api.Error
@ -56,13 +55,13 @@ import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdSo
data Site route = Site
{ _categorySite :: route :-
BranchTag "Categories" "Working with categories."
:> ToServant (CategorySite AsApi)
:> ToServant CategorySite AsApi
, _itemSite :: route :-
BranchTag "Items" "Working with items."
:> ToServant (ItemSite AsApi)
:> ToServant ItemSite AsApi
, _traitSite :: route :-
BranchTag "Item traits" "Working with item traits."
:> ToServant (TraitSite AsApi)
:> ToServant TraitSite AsApi
}
deriving (Generic)
@ -129,7 +128,7 @@ data TraitSite route = TraitSite
}
deriving (Generic)
type Api = ToServant (Site AsApi)
type Api = ToServant Site AsApi
----------------------------------------------------------------------------
-- Client types
@ -266,19 +265,19 @@ class ToCMardown md where toCMarkdown :: md -> CMarkdown
instance ToCMardown MarkdownInline where
toCMarkdown md = CMarkdown
{ text = H $ md^.mdSource
, html = H $ T.decodeUtf8 $ md^.mdHtml
, html = H $ toText $ md^.mdHtml
}
instance ToCMardown MarkdownBlock where
toCMarkdown md = CMarkdown
{ text = H $ md^.mdSource
, html = H $ T.decodeUtf8 $ md^.mdHtml
, html = H $ toText $ md^.mdHtml
}
instance ToCMardown MarkdownTree where
toCMarkdown md = CMarkdown
{ text = H $ md^.mdSource
, html = H $ T.toStrict . renderText $ toHtml md
, html = H $ toText . renderText $ toHtml md
}
----------------------------------------------------------------------------

8
src/Guide/Api/Utils.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
@ -22,7 +23,6 @@ import Data.Aeson
import Data.Swagger hiding (fieldLabelModifier)
import Servant
import Servant.Swagger
import qualified Data.Text.All as T
-- | Nice JSON options.
@ -49,7 +49,7 @@ instance ToJSON field => ToJSON (field ? help) where
instance (KnownSymbol help, ToSchema a) => ToSchema (a ? help) where
declareNamedSchema _ = do
NamedSchema _ s <- declareNamedSchema (Proxy @a)
return $ NamedSchema Nothing (s & description ?~ T.toStrict desc)
return $ NamedSchema Nothing (s & description ?~ toText desc)
where
desc = symbolVal (Proxy @help)
@ -68,11 +68,11 @@ instance (HasSwagger api, KnownSymbol name, KnownSymbol desc) =>
HasSwagger (BranchTag name desc :> api) where
toSwagger _ =
let tag =
Tag (T.toStrict $ symbolVal (Proxy @name))
Tag (toText $ symbolVal (Proxy @name))
((\case
"" -> Nothing
t -> Just t) .
T.toStrict $
toText $
symbolVal (Proxy @desc))
Nothing
in toSwagger (Proxy @api) & applyTags [tag]

4
src/Guide/Archival.hs
View File

@ -16,8 +16,6 @@ where
import Imports
-- text
import qualified Data.Text.All as T
-- JSON
import qualified Data.Aeson as A
-- network
@ -33,7 +31,7 @@ import Guide.Utils
getArchivalStatus :: Manager -> Url -> IO (Either String ArchivalStatus)
getArchivalStatus manager lnk =
handle (pure . Left . show @HttpException) $ do
req <- setQueryString [("url", Just (T.toByteString lnk))] <$>
req <- setQueryString [("url", Just (toByteString lnk))] <$>
parseRequest waybackUrl
fromJsonWith responseParser . responseBody <$!> httpLbs req manager
where

2
src/Guide/Diff/Merge.hs
View File

@ -14,7 +14,7 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Vector
import qualified Data.Vector as V
-- Diffing

6
src/Guide/Diff/Tokenize.hs
View File

@ -14,13 +14,13 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import Data.List.Split
-- | Break text into tokens.
tokenize :: Text -> [Text]
tokenize = consolidate . map T.toStrict . break' . T.toString
tokenize = consolidate . map toText . break' . toString
-- | Break a string into words, spaces, and special characters.
break' :: String -> [String]
@ -84,7 +84,7 @@ consolidate [] = []
-- | Helpful view pattern for matching operators
op :: [Text] -> (Text, [Text])
op = over _1 mconcat . span (isOpToken . T.unpack)
op = over _1 mconcat . span (isOpToken . toString)
where
isOpToken [c] = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String)
isOpToken _ = False

10
src/Guide/Handlers.hs
View File

@ -25,7 +25,7 @@ import qualified Text.Feed.Types as Feed
import qualified Text.Feed.Util as Feed
import qualified Text.Atom.Feed as Atom
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Web
import Web.Spock hiding (head, get, renderRoute, text)
import qualified Web.Spock as Spock
@ -363,7 +363,7 @@ otherMethods = do
feedLastUpdate = case sortedItems of
item:_ -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
_ -> ""
let feedBase = Atom.nullFeed feedUrl feedTitle (T.toStrict feedLastUpdate)
let feedBase = Atom.nullFeed feedUrl feedTitle (toText feedLastUpdate)
entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems
atomFeed $ feedBase {
Atom.feedEntries = entries,
@ -380,7 +380,7 @@ adminMethods = do
(edit, _) <- dbQuery (GetEdit n)
res <- undoEdit edit
case res of
Left err -> Spock.text (T.pack err)
Left err -> Spock.text (toText err)
Right () -> do invalidateCacheForEdit edit
dbUpdate (RemovePendingEdit n)
Spock.text ""
@ -425,11 +425,11 @@ itemToFeedEntry baseUrl category item = do
entryContent <- Lucid.renderTextT (renderItemForFeed category item)
return entryBase {
Atom.entryLinks = [Atom.nullLink entryLink],
Atom.entryContent = Just (Atom.HTMLContent (T.toStrict entryContent)) }
Atom.entryContent = Just (Atom.HTMLContent (toText entryContent)) }
where
entryLink = baseUrl //
format "{}#item-{}" (categorySlug category) (item^.uid)
entryBase = Atom.nullEntry
(uidToText (item^.uid))
(Atom.TextString (item^.name))
(T.toStrict (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)))
(toText (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)))

25
src/Guide/JS.hs
View File

@ -18,7 +18,8 @@ module Guide.JS where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
-- Interpolation
import NeatInterpolation
@ -27,7 +28,7 @@ import Guide.Utils
-- | Javascript code.
newtype JS = JS {fromJS :: Text}
deriving (Show, T.Buildable, Monoid)
deriving (Show, Buildable, Semigroup, Monoid)
-- | A concatenation of all Javascript functions defined in this module.
allJSFunctions :: JS
@ -72,9 +73,9 @@ instance ToJS JS where
instance ToJS Text where
toJS = JS . escapeJSString
instance ToJS Integer where
toJS = JS . T.show
toJS = JS . toText . show
instance ToJS Int where
toJS = JS . T.show
toJS = JS . toText . show
instance ToJS (Uid a) where
toJS = toJS . uidToText
@ -124,7 +125,7 @@ instance JSFunction JS where
makeJSFunction fName fParams fDef =
let paramList = T.intercalate "," fParams
in JS $ format "function "+|fName|+"("+|paramList|+") {\n"
+|indent 2 (build fDef)|+
+|indentF 2 (build fDef)|+
"}\n"
-- This generates a function that takes arguments and produces a Javascript
@ -699,12 +700,12 @@ saveToArchiveOrg =
escapeJSString :: Text -> Text
escapeJSString s =
T.toStrict $
T.bsingleton '"' <> quote s <> T.bsingleton '"'
toText $
B.singleton '"' <> quote s <> B.singleton '"'
where
quote q = case T.uncons t of
Nothing -> T.toBuilder h
Just (!c, t') -> T.toBuilder h <> escape c <> quote t'
Nothing -> toBuilder h
Just (!c, t') -> toBuilder h <> escape c <> quote t'
where
(h, t) = T.break isEscape q
-- 'isEscape' doesn't mention \n, \r and \t because they are handled by
@ -720,12 +721,12 @@ escapeJSString s =
escape '\t' = "\\t"
escape c
| c < '\x20' || c == '\x2028' || c == '\x2029' =
"\\u" <> T.left 4 '0' (T.hex (fromEnum c))
"\\u" <> padLeftF 4 '0' (hexF (fromEnum c))
| otherwise =
T.bsingleton c
B.singleton c
newtype JQuerySelector = JQuerySelector Text
deriving (ToJS, T.Buildable)
deriving (ToJS, Buildable)
selectId :: Text -> JQuerySelector
selectId x = JQuerySelector $ format "#{}" x

17
src/Guide/Main.hs
View File

@ -29,7 +29,8 @@ import Safe (headDef)
-- Monads and monad transformers
import Control.Monad.Morph
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import qualified Data.Text.IO as T
import NeatInterpolation (text)
-- Web
import Web.Spock hiding (head, get, text)
@ -249,20 +250,20 @@ guideApp waiMetrics = do
guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue");
|]
js <- getJS
Spock.bytes $ T.toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
-- CSS
Spock.get "/highlight.css" $ do
setHeader "Content-Type" "text/css; charset=utf-8"
Spock.bytes $ T.toByteString (styleToCss pygments)
Spock.bytes $ toByteString (styleToCss pygments)
Spock.get "/css.css" $ do
setHeader "Content-Type" "text/css; charset=utf-8"
css <- getCSS
Spock.bytes $ T.toByteString css
Spock.bytes $ toByteString css
Spock.get "/admin.css" $ do
setHeader "Content-Type" "text/css; charset=utf-8"
css <- getCSS
admincss <- liftIO $ T.readFile "static/admin.css"
Spock.bytes $ T.toByteString (css <> admincss)
Spock.bytes $ toByteString (css <> admincss)
-- Main page
Spock.get root $
@ -350,7 +351,7 @@ loginAction = do
lucidWithConfig $ renderRegister formHtml
(v, Just Login {..}) -> do
loginAttempt <- dbQuery $
LoginUser loginEmail (T.toByteString loginUserPassword)
LoginUser loginEmail (toByteString loginUserPassword)
case loginAttempt of
Right user -> do
modifySession (sessionUserID .~ Just (user ^. userID))
@ -376,7 +377,7 @@ signupAction = do
lucidWithConfig $ renderRegister formHtml
(v, Just UserRegistration {..}) -> do
user <- makeUser registerUserName registerUserEmail
(T.toByteString registerUserPassword)
(toByteString registerUserPassword)
success <- dbUpdate $ CreateUser user
if success
then do
@ -467,6 +468,6 @@ installTerminationCatcher thread = void $ do
createAdminUser :: GuideApp ()
createAdminUser = do
dbUpdate DeleteAllUsers
pass <- T.toByteString . _adminPassword <$> getConfig
pass <- toByteString . _adminPassword <$> getConfig
user <- makeUser "admin" "admin@guide.aelve.com" pass
void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True)

20
src/Guide/Markdown.hs
View File

@ -41,7 +41,7 @@ where
import Imports hiding (some)
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- ByteString
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
@ -102,9 +102,9 @@ renderMD :: [MD.Node] -> ByteString
renderMD ns
-- See https://github.com/jgm/cmark/issues/147
| any isInlineNode ns =
T.toByteString . sanitize . T.concat . map (nodeToHtml []) $ ns
toByteString . sanitize . T.concat . map (nodeToHtml []) $ ns
| otherwise =
T.toByteString . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns
toByteString . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns
isInlineNode :: MD.Node -> Bool
isInlineNode (MD.Node _ tp _) = case tp of
@ -203,13 +203,13 @@ shortcutLinks node@(MD.Node pos (LINK url title) ns) | "@" <- T.take 1 url =
MD.Node pos (LINK link title) (map shortcutLinks ns)
Warning warnings link ->
let warningText = "[warnings when processing shortcut link: " <>
T.pack (intercalate ", " warnings) <> "]"
toText (intercalate ", " warnings) <> "]"
warningNode = MD.Node Nothing (TEXT warningText) []
in MD.Node pos (LINK link title)
(warningNode : map shortcutLinks ns)
Failure err ->
let errorText = "[error when processing shortcut link: " <>
T.pack err <> "]"
toText err <> "]"
in MD.Node Nothing (TEXT errorText) []
shortcutLinks (MD.Node pos tp ns) =
MD.Node pos tp (map shortcutLinks ns)
@ -233,9 +233,9 @@ parseLink = either (Left . show) Right . parse p ""
p :: Parsec Void Text (Text, Maybe Text, Maybe Text)
p = do
char '@'
(,,) <$> T.pack <$> shortcut
<*> optional (T.pack <$> opt)
<*> optional (T.pack <$> text)
(,,) <$> toText <$> shortcut
<*> optional (toText <$> opt)
<*> optional (toText <$> text)
toMarkdownInline :: Text -> MarkdownInline
toMarkdownInline s = MarkdownInline {
@ -306,11 +306,11 @@ instance Show MarkdownTree where
instance A.ToJSON MarkdownInline where
toJSON md = A.object [
"text" A..= (md^.mdSource),
"html" A..= T.toStrict (md^.mdHtml) ]
"html" A..= toText (md^.mdHtml) ]
instance A.ToJSON MarkdownBlock where
toJSON md = A.object [
"text" A..= (md^.mdSource),
"html" A..= T.toStrict (md^.mdHtml) ]
"html" A..= toText (md^.mdHtml) ]
instance A.ToJSON MarkdownTree where
toJSON md = A.object [
"text" A..= (md^.mdSource) ]

2
src/Guide/Search.hs
View File

@ -10,7 +10,7 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Sets
import qualified Data.Set as S

10
src/Guide/State.hs
View File

@ -108,7 +108,7 @@ import Imports
import qualified Data.Map as M
import qualified Data.Set as S
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Network
import Data.IP
-- acid-state
@ -245,26 +245,26 @@ traitById uid' = singular $
(pros.each . filtered (hasUid uid')) `failing`
(cons.each . filtered (hasUid uid')) `failing`
error ("traitById: couldn't find trait with uid " ++
T.unpack (uidToText uid'))
toString (uidToText uid'))
categoryById :: Uid Category -> Lens' GlobalState Category
categoryById catId = singular $
categories.each . filtered (hasUid catId) `failing`
error ("categoryById: couldn't find category with uid " ++
T.unpack (uidToText catId))
toString (uidToText catId))
itemById :: Uid Item -> Lens' GlobalState Item
itemById itemId = singular $
categories.each . items.each . filtered (hasUid itemId) `failing`
error ("itemById: couldn't find item with uid " ++
T.unpack (uidToText itemId))
toString (uidToText itemId))
findCategoryByItem :: Uid Item -> GlobalState -> Category
findCategoryByItem itemId s =
fromMaybe (error err) (find hasItem (s^.categories))
where
err = "findCategoryByItem: couldn't find category with item with uid " ++
T.unpack (uidToText itemId)
toString (uidToText itemId)
hasItem category = itemId `elem` (category^..items.each.uid)
-- | 'PublicDB' contains all safe data from 'GlobalState'.

2
src/Guide/Types/Core.hs
View File

@ -60,7 +60,7 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Containers
import qualified Data.Set as S
-- JSON

36
src/Guide/Utils.hs
View File

@ -81,7 +81,7 @@ import qualified Data.Set as S
-- Randomness
import System.Random
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
-- Bytestring
import qualified Data.ByteString.Lazy as BSL
-- JSON
@ -177,7 +177,7 @@ sanitiseUrl :: Url -> Maybe Url
sanitiseUrl u
| not (sanitaryURI u) = Nothing
| otherwise =
Just $ case URI.uriScheme <$> parse (T.toString u) of
Just $ case URI.uriScheme <$> parse (toString u) of
Nothing -> "http://" <> u
Just "" -> "http://" <> u
_ -> u
@ -254,24 +254,24 @@ data ReferrerView
instance Show ReferrerView where
show (RefSearchEngine searchEngine keyword)
= show searchEngine <> showKeyword keyword
show (RefUrl url) = T.toString url
show (RefUrl url) = toString url
showKeyword :: Text -> String
showKeyword "" = ""
showKeyword kw = " (\"" <> T.toString kw <> "\")"
showKeyword kw = " (\"" <> toString kw <> "\")"
extractQuery :: Url -> Maybe Query
extractQuery url = getQuery <$> parse url
where
getQuery = parseQuery . T.toByteString . URI.uriQuery
parse = URI.parseURI . T.toString
getQuery = parseQuery . toByteString . URI.uriQuery
parse = URI.parseURI . toString
-- TODO: different search engines have different parameters, we should use
-- right ones instead of just trying “whatever fits”
extractKeyword :: Url -> Maybe Text
extractKeyword url
= case extractQuery url of
Just query -> T.toStrict <$> lookupQuery query
Just query -> toText <$> lookupQuery query
Nothing -> Nothing
where
lookupQuery :: [(ByteString, Maybe ByteString)] -> Maybe ByteString
@ -286,9 +286,9 @@ toReferrerView url
Just se -> RefSearchEngine se (fromMaybe "" keyword)
Nothing -> RefUrl url
where
uri = URI.parseURI $ T.toString url
uri = URI.parseURI $ toString url
uriAuth = URI.uriAuthority =<< uri
domain = T.toStrict . URI.uriRegName <$> uriAuth
domain = toText . URI.uriRegName <$> uriAuth
keyword = extractKeyword url
----------------------------------------------------------------------------
@ -312,7 +312,7 @@ sockAddrToIP _ = Nothing
newtype Uid a = Uid {uidToText :: Text}
deriving (Generic, Eq, Ord, Show, Data,
ToHttpApiData, FromHttpApiData,
T.Buildable, Hashable)
Buildable, Hashable)
instance A.ToJSON (Uid a) where
toJSON = A.toJSON . uidToText
@ -327,7 +327,7 @@ instance SafeCopy (Uid a) where
kind = base
instance IsString (Uid a) where
fromString = Uid . T.toStrict
fromString = Uid . toText
-- | Generate a random text of given length from characters @a-z@ and digits.
randomText :: MonadIO m => Int -> m Text
@ -341,7 +341,7 @@ randomText n = liftIO $ do
return $ if i < 10 then toEnum (fromEnum '0' + i)
else toEnum (fromEnum 'a' + i - 10)
xs <- replicateM (n-1) randomChar
return (T.toStrict (x:xs))
return (toText (x:xs))
-- For probability tables, see
-- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
@ -410,14 +410,14 @@ instance AsJson LByteString where
toJsonPretty = A.encodePretty
instance AsJson Text where
fromJson = A.eitherDecode . T.toLByteString
toJson = T.toStrict . A.encodeToLazyText
toJsonPretty = T.toStrict . A.encodePrettyToTextBuilder
fromJson = A.eitherDecode . toLByteString
toJson = toText . A.encodeToLazyText
toJsonPretty = toText . A.encodePrettyToTextBuilder
instance AsJson LText where
fromJson = A.eitherDecode . T.toLByteString
fromJson = A.eitherDecode . toLByteString
toJson = A.encodeToLazyText
toJsonPretty = T.toLazy . A.encodePrettyToTextBuilder
toJsonPretty = toLText . A.encodePrettyToTextBuilder
instance AsJson A.Value where
fromJsonWith p v = case A.iparse p v of
@ -461,7 +461,7 @@ getRequestDetails = do
(Spock.header "X-Forwarded-For")
mbIP <- case mbForwardedFor of
Nothing -> sockAddrToIP . Wai.remoteHost <$> Spock.request
Just ff -> case readMaybe (T.unpack ip) of
Just ff -> case readMaybe (toString ip) of
Nothing -> error ("couldn't read Forwarded-For address: " ++
show ip ++ " (full header: " ++
show ff ++ ")")

18
src/Guide/Views.hs
View File

@ -38,9 +38,9 @@ import Guide.Views.Category as X
import Imports
import Data.Monoid ((<>))
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import qualified Data.Text.IO as T
import NeatInterpolation
-- Web
import Lucid hiding (for_)
@ -246,7 +246,7 @@ renderStats globalState acts = do
let findCategory catId = fromMaybe err (find (hasUid catId) allCategories)
where
err = error ("renderStats: couldn't find category with uid = " ++
T.unpack (uidToText catId))
toString (uidToText catId))
table_ [class_ "sortable"] $ do
thead_ $ tr_ $ do
th_ [class_ "sorttable_nosort"] "Category"
@ -376,13 +376,13 @@ renderEdit globalState edit = do
let findCategory catId = fromMaybe err (find (hasUid catId) allCategories)
where
err = error ("renderEdit: couldn't find category with uid = " ++
T.unpack (uidToText catId))
toString (uidToText catId))
let findItem itemId = (category, item)
where
getItems = view (items <> itemsDeleted)
ourCategory = any (hasUid itemId) . getItems
err = error ("renderEdit: couldn't find item with uid = " ++
T.unpack (uidToText itemId))
toString (uidToText itemId))
category = fromMaybe err (find ourCategory allCategories)
item = fromJust (find (hasUid itemId) (getItems category))
let findTrait itemId traitId = (category, item, trait)
@ -390,7 +390,7 @@ renderEdit globalState edit = do
(category, item) = findItem itemId
getTraits = view (cons <> consDeleted <> pros <> prosDeleted)
err = error ("renderEdit: couldn't find trait with uid = " ++
T.unpack (uidToText traitId))
toString (uidToText traitId))
trait = fromMaybe err (find (hasUid traitId) (getTraits item))
let printCategory catId = do
@ -851,8 +851,8 @@ renderAdminLinks globalState = do
div_ [id_ "stats"] $ do
manager <- liftIO $ newManager tlsManagerSettings
fullList <- liftIO $ forM allLinks $ \(lnk, location) -> do
lnkStatus <- if isURI (T.unpack lnk) then (do
request <- parseRequest $ T.unpack lnk
lnkStatus <- if isURI (toString lnk) then (do
request <- parseRequest $ toString lnk
status' <- responseStatus <$> httpNoBody request manager
print (lnk, status')
pure $ case status' of
@ -930,7 +930,7 @@ renderArchivalStatus = \case
Left err -> "couldn't get info from archive.org: " <> toHtml err
Right ArchivalStatus{..}
| asAvailable -> do
a_ [href_ asUrl] (toHtml (T.toStrict (dateDashF asTimestamp)))
a_ [href_ asUrl] (toHtml (toText (dateDashF asTimestamp)))
unless (asStatus == "200") $
toHtml (format " (status: {})" asStatus :: Text)
| otherwise -> "unavailable"

2
src/Guide/Views/Category.hs
View File

@ -23,7 +23,7 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text.IO as T
-- HTML
import Lucid hiding (for_)

2
src/Guide/Views/Item.hs
View File

@ -33,7 +33,7 @@ import Imports
import qualified Data.Map as M
import Data.Tree
-- Text
import qualified Data.Text.All as T
import qualified Data.Text.IO as T
-- HTML
import Lucid hiding (for_)
-- JSON

2
src/Guide/Views/Page.hs
View File

@ -32,7 +32,7 @@ where
import Imports
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import NeatInterpolation
-- Web
import Lucid hiding (for_)

11
src/Guide/Views/Utils.hs
View File

@ -69,7 +69,8 @@ import Data.List.Split
import qualified Data.Map as M
-- import Data.Tree
-- Text
import qualified Data.Text.All as T
import qualified Data.Text as T
import qualified Data.Text.IO as T
-- digestive-functors
import Text.Digestive (View)
-- import NeatInterpolation
@ -299,7 +300,7 @@ mustache f v = do
when (null templates) $
error "View.mustache: no HTML templates found in templates/"
parsed <- for templates $ \(tname, t) -> do
let pname = fromString (T.unpack tname)
let pname = fromString (toString tname)
case compileMustacheText pname t of
Left e -> error $ printf "View.mustache: when parsing %s: %s"
tname (parseErrorPretty e)
@ -340,13 +341,13 @@ readWidget fp = liftIO $ do
sectionTypeP = choice [
do string "HTML"
HTML_ <$> choice [
string ": " >> (T.pack <$> some anyChar),
return (T.pack (takeBaseName fp)) ],
string ": " >> (toText <$> some anyChar),
return (toText (takeBaseName fp)) ],
string "JS" $> JS_,
string "CSS" $> CSS_,
string "Description" $> Description_,
do string "Note ["
Note_ . T.pack <$> someTill anyChar (char ']') ]
Note_ . toText <$> someTill anyChar (char ']') ]
let parseSectionType t = case parse (sectionTypeP <* eof) fp t of
Right x -> x
Left e -> error $ printf "invalid section name: '%s'\n%s"

12
src/Imports.hs
View File

@ -8,13 +8,16 @@ the "Prelude".)
module Imports
(
module X,
LByteString
LByteString,
LText,
)
where
import BasePrelude as X
hiding (Category, GeneralCategory, lazy, Handler, diff, option)
-- Conversions
import To as X
-- Lists
import Data.List.Extra as X (dropEnd, takeEnd)
import Data.List.Index as X
@ -28,7 +31,7 @@ import Control.Monad.Except as X
import Data.ByteString as X (ByteString)
import Data.Map as X (Map)
import Data.Set as X (Set)
import Data.Text.All as X (LText, Text)
import Data.Text as X (Text)
-- Time
import Data.Time as X
-- Files
@ -38,11 +41,12 @@ import System.FilePath as X
import Control.DeepSeq as X
-- Hashable
import Data.Hashable as X
-- Lazy bytestring
-- Lazy
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Lazy as TL
-- Formatting
import Fmt as X
type LByteString = BSL.ByteString
-- LText is already provided by Data.Text.All
type LText = TL.Text

132
src/To.hs Normal file
View File

@ -0,0 +1,132 @@
{-# LANGUAGE TypeSynonymInstances, GADTs #-}
module To
( toText
, toLText
, toByteString
, toLByteString
, toString
, toBuilder
) where
import Prelude
import Data.Text
import Data.Text.Encoding
import Data.Text.Encoding.Error
import qualified Data.Text.Lazy.Builder as B
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as UTF8L
class ToText t where
toText :: t -> Text
instance (a ~ Char) => ToText [a] where
toText = pack
{-# INLINE toText #-}
instance ToText TL.Text where
toText = TL.toStrict
{-# INLINE toText #-}
instance ToText Builder where
toText = TL.toStrict . B.toLazyText
{-# INLINE toText #-}
instance ToText BS.ByteString where
toText = decodeUtf8With lenientDecode
{-# INLINE toText #-}
instance ToText BSL.ByteString where
toText = decodeUtf8With lenientDecode . BSL.toStrict
{-# INLINE toText #-}
class ToLText t where
toLText :: t -> TL.Text
instance (a ~ Char) => ToLText [a] where
toLText = TL.pack
{-# INLINE toLText #-}
instance ToLText Text where
toLText = TL.fromStrict
{-# INLINE toLText #-}
instance ToLText Builder where
toLText = B.toLazyText
{-# INLINE toLText #-}
instance ToLText BS.ByteString where
toLText = TL.fromStrict . decodeUtf8With lenientDecode
{-# INLINE toLText #-}
instance ToLText BSL.ByteString where
toLText = TL.decodeUtf8With lenientDecode
{-# INLINE toLText #-}
class ToBuilder t where
toBuilder :: t -> Builder
instance (a ~ Char) => ToBuilder [a] where
toBuilder = B.fromString
{-# INLINE toBuilder #-}
instance ToBuilder Text where
toBuilder = B.fromText
{-# INLINE toBuilder #-}
instance ToBuilder TL.Text where
toBuilder = B.fromLazyText
{-# INLINE toBuilder #-}
instance ToBuilder BS.ByteString where
toBuilder = B.fromText . decodeUtf8With lenientDecode
{-# INLINE toBuilder #-}
instance ToBuilder BSL.ByteString where
toBuilder = B.fromLazyText . TL.decodeUtf8With lenientDecode
{-# INLINE toBuilder #-}
class ToString t where
toString :: t -> String
instance ToString Text where
toString = unpack
{-# INLINE toString #-}
instance ToString TL.Text where
toString = TL.unpack
{-# INLINE toString #-}
instance ToString Builder where
toString = TL.unpack . B.toLazyText
{-# INLINE toString #-}
instance ToString BS.ByteString where
toString = UTF8.toString
{-# INLINE toString #-}
instance ToString BSL.ByteString where
toString = UTF8L.toString
{-# INLINE toString #-}
class ToByteString t where
toByteString :: t -> BS.ByteString
instance ToByteString Text where
toByteString = encodeUtf8
{-# INLINE toByteString #-}
instance ToByteString TL.Text where
toByteString = encodeUtf8 . TL.toStrict
{-# INLINE toByteString #-}
instance ToByteString Builder where
toByteString = encodeUtf8 . TL.toStrict . B.toLazyText
{-# INLINE toByteString #-}
instance (a ~ Char) => ToByteString [a] where
toByteString = UTF8.fromString
{-# INLINE toByteString #-}
class ToLByteString t where
toLByteString :: t -> BSL.ByteString
instance ToLByteString Text where
toLByteString = TL.encodeUtf8 . TL.fromStrict
{-# INLINE toLByteString #-}
instance ToLByteString TL.Text where
toLByteString = TL.encodeUtf8
{-# INLINE toLByteString #-}
instance ToLByteString Builder where
toLByteString = TL.encodeUtf8 . B.toLazyText
{-# INLINE toLByteString #-}
instance (a ~ Char) => ToLByteString [a] where
toLByteString = UTF8L.fromString
{-# INLINE toLByteString #-}

23
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-11.13
resolver: lts-12.4
packages:
- location: .
@ -7,19 +7,30 @@ nix:
shell-file: shell.nix
extra-deps:
- text-all-0.4.2
- cmark-sections-0.3.0.1
- fmt-0.4.0.0
- Spock-0.13.0.0
- Spock-core-0.13.0.0
- Spock-digestive-0.3.0.0
- digestive-functors-0.8.4.0
- servant-generic-0.1.0.3
- Spock-lucid-0.4.0.1
- reroute-0.5.0.0
- cmark-0.5.6
- cmark-highlight-0.2.0.0
- fmt-0.6
- cmark-sections-0.3.0.1
- acid-state-0.14.3
- servant-swagger-ui-redoc-0.3.0.1.21.2
- file-embed-lzma-0
- servant-0.14.1
- servant-swagger-1.1.5
- servant-swagger-ui-core-0.3.1
- swagger2-2.3
- git: https://github.com/neongreen/patches-vector
commit: 9bb704cf7f14cff9ef76a5d177e4e56ceee24705
- git: https://github.com/aelve/stache-plus
commit: e2a8d986bd4014f889d3fa60a64e8db0ea199885
commit: c8097fb33df6ba738fc7b7c8d09aaebdb02a9782
- git: https://github.com/aelve/safecopy-migrate
commit: c401315122f04624e5e848d77f9eaa948e38c21b
- git: https://github.com/neongreen/webdriver-utils
commit: 34a7ae7358ec738cc8ab94569693f7571433f153
subdirs:
- hspec-webdriver

4
static/components/CategoryItemInfo.js
View File

@ -86,7 +86,7 @@ Vue.component('CategoryItemInfoEdit', {
// We use 'autocomplete=off' everywhere due to this:
// http://stackoverflow.com/q/8311455
template: `
<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid.uidToText}}', this); return false;">
<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid}}', this); return false;">
<label for="name">Name</label>
<input id="name" name="name" value="{{item.name}}"
type="text" autocomplete="off">
@ -127,7 +127,7 @@ Vue.component('CategoryItemInfoEdit', {
<div class="form-btn-group">
<input value="Save" class="save" type="submit">
<input value="Cancel" class="cancel" type="button"
onclick="itemInfoCancelEdit('{{item.uid.uidToText}}');">
onclick="itemInfoCancelEdit('{{item.uid}}');">
</div>
</form>
`,

4
templates/item-description.widget
View File

@ -19,7 +19,7 @@ HTML
title = "edit summary"
class = "edit-item-description"
action = [| editItemDescription(
{{{%js item.uid.uidToText}}},
{{{%js item.uid}}},
{{{%js item.description.text}}}); |] }}
<div class="notes-like">
{{# item.description.text}}
@ -38,7 +38,7 @@ HTML
src = "/pencil.svg"
title = "quit editing summary"
class = "edit-item-description"
action = [| stopEditingItemDescription({{{%js item.uid.uidToText}}}); |] }}
action = [| stopEditingItemDescription({{{%js item.uid}}}); |] }}
<div class="editor"></div>
</div>
</div>

12
templates/item-info.widget
View File

@ -79,25 +79,25 @@ HTML: item-info-controls
src = "/arrow-thick-top.svg"
title = "move item up"
class = "move-item-up"
action = [| moveItem("up", {{{%js item.uid.uidToText}}}); |] }}
action = [| moveItem("up", {{{%js item.uid}}}); |] }}
{{> img-button
src = "/arrow-thick-bottom.svg"
title = "move item down"
class = "move-item-down"
action = [| moveItem("down", {{{%js item.uid.uidToText}}}); |] }}
action = [| moveItem("down", {{{%js item.uid}}}); |] }}
</span>
<span>
{{> img-button
src = "/cog.svg"
title = "edit item info"
class = "edit-item-info"
action = [| editItemInfo({{{%js item.uid.uidToText}}}); |] }}
action = [| editItemInfo({{{%js item.uid}}}); |] }}
{{> space em=0.4 }}
{{> img-button
src = "/x.svg"
title = "delete item"
class = "delete-item"
action = [| deleteItem({{{%js item.uid.uidToText}}}); |] }}
action = [| deleteItem({{{%js item.uid}}}); |] }}
</span>
</div>
@ -177,7 +177,7 @@ CSS
HTML: item-info-edit-form
------------------------------------------------------------
{{! "autocomplete=off" everywhere: http://stackoverflow.com/q/8311455 }}
<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid.uidToText}}', this); return false;">
<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid}}', this); return false;">
<label for="name">
Name
</label>
@ -228,7 +228,7 @@ HTML: item-info-edit-form
<div class="form-btn-group">
<input value="Save" class="save" type="submit">
<input value="Cancel" class="cancel" type="button"
onclick="itemInfoCancelEdit('{{item.uid.uidToText}}');">
onclick="itemInfoCancelEdit('{{item.uid}}');">
</div>
</form>

14
templates/trait.widget
View File

@ -5,9 +5,9 @@ A list item containing a trait (pro/con), together with some JS that lets the us
Required context:
* item.uid.uidToText
* item.uid
* trait.uid.uidToText
* trait.uid
trait.content.html
trait.content.text
@ -15,7 +15,7 @@ Required context:
HTML
============================================================
<li id="trait-{{trait.uid.uidToText}}">
<li id="trait-{{trait.uid}}">
<div class="section normal editable shown noscript-shown">
{{{trait.content.html}}}
@ -26,22 +26,22 @@ HTML
{{> small-control
src = "/arrow-thick-top.svg"
title = "move trait up"
action = [| moveTrait("up",{{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
action = [| moveTrait("up",{{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
{{> small-control
src = "/arrow-thick-bottom.svg"
title = "move trait down"
action = [| moveTrait("down",{{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
action = [| moveTrait("down",{{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
{{> space px=16}}
{{> small-control
src = "/pencil.svg"
title = "edit trait"
action = [| editTrait({{{%js item.uid.uidToText}}}, {{{%js trait.uid.uidToText}}},
action = [| editTrait({{{%js item.uid}}}, {{{%js trait.uid}}},
{{{%js trait.content.text}}}); |] }}
{{> space px=16}}
{{> small-control
src = "/x.svg"
title = "delete trait"
action = [| deleteTrait({{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
action = [| deleteTrait({{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
</div>
</div>

7
tests/MarkdownSpec.hs
View File

@ -9,8 +9,9 @@ import BasePrelude
-- Lenses
import Lens.Micro.Platform
-- Text
import qualified Data.Text.All as T
import Data.Text.All (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text (Text)
-- HTML
import Text.HTML.TagSoup hiding (sections)
import Lucid (ToHtml, toHtml, renderText)
@ -144,7 +145,7 @@ getTags :: Text -> [Text]
getTags html = nub [t | TagOpen t _ <- parseTags html]
htmlToText :: ToHtml a => a -> Text
htmlToText = T.toStrict . renderText . toHtml
htmlToText = TL.toStrict . renderText . toHtml
allMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec
allMarkdowns f = do

4
tests/MergeSpec.hs
View File

@ -7,8 +7,8 @@ module MergeSpec (tests) where
import BasePrelude
-- Text
import qualified Data.Text.All as T
import Data.Text.All (Text)
import qualified Data.Text as T
import Data.Text (Text)
-- Testing
import Test.Hspec
import Test.Hspec.QuickCheck

8
tests/Selenium.hs
View File

@ -64,8 +64,8 @@ import Control.Monad.Loops
-- Containers
import qualified Data.Set as Set
-- Text
import Data.Text.All (Text)
import qualified Data.Text.All as T
import Data.Text (Text)
import qualified Data.Text as T
-- Testing
import Test.Hspec.WebDriver hiding
(getText, shouldHaveAttr, shouldHaveText, click, cssProp, attr,
@ -88,7 +88,7 @@ getLink s = do
linkElems <- selectAll ((e :& "a") :| (e :// "a"))
links <- nub . catMaybes <$> mapM (flip attr "href") linkElems
case links of
[x] -> return (T.toString x)
[x] -> return (T.unpack x)
[] -> expectationFailure $
printf "expected %s to contain a link" (show s)
_ -> expectationFailure $
@ -349,7 +349,7 @@ fontSize s = do
case mbProp of
Nothing -> expectationFailure $
printf "expected %s to have font-size" (show s)
Just fs -> case reads (T.toString fs) of
Just fs -> case reads (T.unpack fs) of
[(d, "px")] -> return d
_ -> expectationFailure $
printf "couldn't parse font-size of %s: %s" (show s) (show fs)

8
tests/WebSpec.hs
View File

@ -14,8 +14,8 @@ import Control.Monad.Loops
-- Concurrency
import qualified SlaveThread as Slave
-- Text
import Data.Text.All (Text)
import qualified Data.Text.All as T
import Data.Text (Text)
import qualified Data.Text as T
-- Files
import System.Directory
-- URLs
@ -472,14 +472,14 @@ markdownTests = session "markdown" $ using [chromeCaps] $ do
parseCategoryURL :: String -> WD (String, String)
parseCategoryURL url = do
case T.stripPrefix "/haskell/" (T.toStrict url) of
case T.stripPrefix "/haskell/" (T.pack url) of
Nothing -> expectationFailure $
printf "%s doesn't start with /haskell/" (show url)
Just u -> do
let (slug, catId) = T.breakOnEnd "-" u
slug `shouldSatisfy` ("not null", not . T.null)
T.last slug `shouldBe` '-'
return (T.toString (T.init slug), T.toString catId)
return (T.unpack (T.init slug), T.unpack catId)
openGuide :: String -> SpecWith (WdTestSession ())
openGuide s = wd ("load " ++ s) (openGuidePage s)