Move Uid into a separate module (#388)

back/src/Guide/Api/Methods.hs

@@ -23,6 +23,7 @@ import Guide.Markdown (MarkdownBlock (..), MarkdownInline (..), MarkdownTree (..
 import Guide.State
 import Guide.Types
 import Guide.Utils
+import Guide.Uid
 
 import qualified Data.Set as S
 import qualified Data.Text as T

back/src/Guide/Api/Types.hs

@@ -62,7 +62,8 @@ import Guide.Api.Utils
 import Guide.Markdown
 import Guide.Search
 import Guide.Types.Core as G
-import Guide.Utils (Uid (..), Url, fields)
+import Guide.Uid
+import Guide.Utils (Url, fields)
 
 import qualified Data.Aeson as Aeson
 import Data.Swagger as S

back/src/Guide/Database/Import.hs

@@ -20,7 +20,7 @@ import Guide.Database.Schema
 import Guide.Database.Types
 import Guide.State
 import Guide.Types.Core
-import Guide.Utils (Uid (..))
+import Guide.Uid
 import Guide.Config
 import Guide.Logger
 

back/src/Guide/Database/Queries/Delete.hs

@@ -20,7 +20,7 @@ import Guide.Database.Queries.Update
 import Guide.Database.Types
 import Guide.Database.Utils
 import Guide.Types.Core
-import Guide.Utils (Uid (..))
+import Guide.Uid
 
 -- | Delete a category completly.
 deleteCategory :: Uid Category -> ExceptT DatabaseError Transaction ()

back/src/Guide/Database/Queries/Insert.hs

@@ -24,7 +24,7 @@ import Guide.Database.Queries.Update
 import Guide.Database.Types
 import Guide.Database.Utils (execute)
 import Guide.Types.Core
-import Guide.Utils (Uid (..))
+import Guide.Uid
 
 
 ----------------------------------------------------------------------------

back/src/Guide/Database/Queries/Select.hs

@@ -40,7 +40,7 @@ import qualified Hasql.Transaction as HT
 import Guide.Database.Types
 import Guide.Database.Utils
 import Guide.Types.Core
-import Guide.Utils (Uid (..))
+import Guide.Uid
 
 ----------------------------------------------------------------------------
 -- Categories

back/src/Guide/Database/Queries/Update.hs

@@ -20,7 +20,8 @@ import Guide.Database.Queries.Select
 import Guide.Database.Types
 import Guide.Database.Utils
 import Guide.Types.Core
-import Guide.Utils (Uid (..), fieldsPrefixed)
+import Guide.Uid
+import Guide.Utils (fieldsPrefixed)
 
 
 ----------------------------------------------------------------------------

back/src/Guide/Database/Types.hs

@@ -25,7 +25,8 @@ import Imports
 
 import Guide.Markdown (toMarkdownBlock, toMarkdownTree, toMarkdownInline, markdownBlockSource, markdownTreeSource, markdownInlineSource)
 import Guide.Types.Core
-import Guide.Utils (Uid (..), makeClassWithLenses, fields)
+import Guide.Uid
+import Guide.Utils (makeClassWithLenses, fields)
 import Guide.Database.Utils
 
 

back/src/Guide/Database/Utils.hs

@@ -39,7 +39,7 @@ import qualified Data.Set as Set
 import qualified Hasql.Encoders as HE
 import qualified Hasql.Decoders as HD
 
-import Guide.Utils (Uid (..))
+import Guide.Uid
 
 ----------------------------------------------------------------------------
 -- Query functions

back/src/Guide/Handlers.hs

@@ -26,6 +26,7 @@ import Guide.State
 import Guide.Types
 import Guide.Utils
 import Guide.Views
+import Guide.Uid
 
 import qualified Data.Set as S
 import qualified Data.Text as T

back/src/Guide/JS.hs

@@ -17,7 +17,7 @@ import Imports
 
 import NeatInterpolation
 
-import Guide.Utils
+import Guide.Uid
 
 import qualified Data.Text as T
 import qualified Data.Text.Lazy.Builder as B
@@ -726,7 +726,7 @@ newtype JQuerySelector = JQuerySelector Text
 selectId :: Text -> JQuerySelector
 selectId x = JQuerySelector $ format "#{}" x
 
-selectUid :: Uid Node -> JQuerySelector
+selectUid :: Uid a -> JQuerySelector
 selectUid x = JQuerySelector $ format "#{}" x
 
 selectClass :: Text -> JQuerySelector

back/src/Guide/Main.hs

@@ -55,7 +55,7 @@ import Guide.ServerStuff
 import Guide.Session
 import Guide.State
 import Guide.Types
-import Guide.Utils
+import Guide.Uid
 import Guide.Views
 import Guide.Views.Utils (getCSS, getCsrfHeader, getJS, protectForm)
 import Guide.Database.Import (loadIntoPostgres)

back/src/Guide/ServerStuff.hs

@@ -36,6 +36,7 @@ import Guide.Markdown
 import Guide.State
 import Guide.Types
 import Guide.Utils
+import Guide.Uid
 
 import qualified Web.Spock as Spock
 

back/src/Guide/State.hs

@@ -100,6 +100,7 @@ import Data.SafeCopy.Migrate
 --
 import Web.Spock.Internal.SessionManager (SessionId)
 
+import Guide.Uid
 import Guide.Markdown
 import Guide.Types.Analytics
 import Guide.Types.Core

back/src/Guide/Types/Analytics.hs

@@ -29,6 +29,7 @@ import Data.IP
 import Data.SafeCopy hiding (kind)
 import Data.SafeCopy.Migrate
 
+import Guide.Uid
 import Guide.Types.Core
 import Guide.Types.Edit
 import Guide.Utils

back/src/Guide/Types/Core.hs

@@ -34,6 +34,7 @@ import Data.SafeCopy.Migrate
 import Guide.Markdown
 import Guide.Types.Hue
 import Guide.Utils
+import Guide.Uid
 import Guide.Database.Utils (ToPostgres (..), FromPostgres (..))
 
 import qualified Data.Aeson as Aeson

back/src/Guide/Types/Edit.hs

@@ -22,6 +22,7 @@ import Data.SafeCopy.Migrate
 
 import Guide.Types.Core
 import Guide.Utils
+import Guide.Uid
 
 
 -- | Edits made by users. It should always be possible to undo an edit.

back/src/Guide/Types/Session.hs

@@ -22,7 +22,7 @@ import Data.SafeCopy.Migrate
 import Web.Spock.Internal.SessionManager (SessionId)
 
 import Guide.Types.User
-import Guide.Utils
+import Guide.Uid
 
 import qualified Web.Spock.Internal.SessionManager as Spock
 

back/src/Guide/Types/User.hs

@@ -21,6 +21,7 @@ import Data.SafeCopy.Migrate
 -- scrypt
 import Crypto.Scrypt (EncryptedPass (..), Pass (..), encryptPassIO', getEncryptedPass, verifyPass')
 
+import Guide.Uid
 import Guide.Utils
 
 

back/src/Guide/Uid.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | A type for unique identifiers.
+module Guide.Uid
+(
+  Uid(..),
+  randomShortUid,
+  randomLongUid,
+)
+where
+
+import Imports
+import Data.Aeson
+import Data.SafeCopy
+import Web.HttpApiData
+import System.Random (randomRIO)
+
+----------------------------------------------------------------------------
+-- Type
+----------------------------------------------------------------------------
+
+-- | Unique id, used for many things – categories, items, and anchor ids.
+newtype Uid a = Uid {uidToText :: Text}
+  deriving stock (Generic, Eq, Ord, Data)
+  deriving newtype
+    (Read, Show, IsString, Buildable, ToHttpApiData, FromHttpApiData,
+     Hashable, ToJSON, FromJSON)
+
+----------------------------------------------------------------------------
+-- Instances
+----------------------------------------------------------------------------
+
+-- This instance is written manually because otherwise it produces a warning:
+--     • Redundant constraint: SafeCopy a
+--     • In the instance declaration for ‘SafeCopy (Uid a)’
+instance SafeCopy (Uid a) where
+  putCopy = contain . safePut . uidToText
+  getCopy = contain (Uid <$> safeGet)
+  version = 2
+  kind = base
+
+----------------------------------------------------------------------------
+-- Generating random uids
+----------------------------------------------------------------------------
+
+-- | Generate a random text of given length from characters @a-z@ and digits.
+randomText :: MonadIO m => Int -> m Text
+randomText n = liftIO $ do
+  -- We don't want the 1st char to be a digit. Just in case (I don't really
+  -- have a good reason). Maybe to prevent Javascript from doing automatic
+  -- conversions or something (though it should never happen).
+  x <- randomRIO ('a', 'z')
+  let randomChar = do
+        i <- randomRIO (0, 35)
+        return $ if i < 10 then toEnum (fromEnum '0' + i)
+                           else toEnum (fromEnum 'a' + i - 10)
+  xs <- replicateM (n-1) randomChar
+  return (toText (x:xs))
+
+-- For probability tables, see
+-- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
+
+-- | Generate a random UID of length 12.
+--
+-- Probability of collision for
+--
+--   * a million UIDs: approximately 1e-6
+--   * a billion UIDs: approximately 0.25
+randomLongUid :: MonadIO m => m (Uid a)
+randomLongUid = Uid <$> randomText 12
+
+-- | Generate a random UID of length 8.
+--
+-- These UIDs are only used for items and categories (because their uids can
+-- occur in links and so they should look a bit nicer).
+--
+-- Probability of collision for
+--
+--   * a hundred thousand UIDs: approximately 0.5%
+--   * a million UIDs: approximately 40%
+randomShortUid :: MonadIO m => m (Uid a)
+randomShortUid = Uid <$> randomText 8

back/src/Guide/Utils.hs

@@ -33,13 +33,6 @@ module Guide.Utils
   -- * IP
   sockAddrToIP,
 
-  -- * UID
-  Uid(..),
-  Node,
-  randomShortUid,
-  randomLongUid,
-  uid_,
-
   -- * JSON
   fromJson,
   fromJsonWith,
@@ -301,84 +294,6 @@ sockAddrToIP (Network.SockAddrInet  _   x)   = Just (IPv4 (fromHostAddress x))
 sockAddrToIP (Network.SockAddrInet6 _ _ x _) = Just (IPv6 (fromHostAddress6 x))
 sockAddrToIP _                               = Nothing
 
-----------------------------------------------------------------------------
--- Uid
-----------------------------------------------------------------------------
-
--- | Unique id, used for many things – categories, items, and anchor ids.
-newtype Uid a = Uid {uidToText :: Text}
-  deriving (Generic, Eq, Ord, Data,
-            ToHttpApiData, FromHttpApiData,
-            Buildable, Hashable)
-
-instance Show (Uid a) where
-  show (Uid a) = show a
-
-instance Aeson.ToJSON (Uid a) where
-  toJSON = Aeson.toJSON . uidToText
-
-instance Aeson.FromJSON (Uid a) where
-  parseJSON a = Uid <$> Aeson.parseJSON a
-
--- This instance is written manually because otherwise it produces a warning:
---     • Redundant constraint: SafeCopy a
---     • In the instance declaration for ‘SafeCopy (Uid a)’
-instance SafeCopy (Uid a) where
-  putCopy = contain . safePut . uidToText
-  getCopy = contain (Uid <$> safeGet)
-  version = 2
-  kind = base
-
-instance IsString (Uid a) where
-  fromString = Uid . toText
-
--- | Generate a random text of given length from characters @a-z@ and digits.
-randomText :: MonadIO m => Int -> m Text
-randomText n = liftIO $ do
-  -- We don't want the 1st char to be a digit. Just in case (I don't really
-  -- have a good reason). Maybe to prevent Javascript from doing automatic
-  -- conversions or something (though it should never happen).
-  x <- randomRIO ('a', 'z')
-  let randomChar = do
-        i <- randomRIO (0, 35)
-        return $ if i < 10 then toEnum (fromEnum '0' + i)
-                           else toEnum (fromEnum 'a' + i - 10)
-  xs <- replicateM (n-1) randomChar
-  return (toText (x:xs))
-
--- For probability tables, see
--- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
-
--- | Generate a random UID of length 12.
---
--- Probability of collision for
---
---   * a million UIDs: approximately 1e-6
---   * a billion UIDs: approximately 0.25
---
-randomLongUid :: MonadIO m => m (Uid a)
-randomLongUid = Uid <$> randomText 12
-
--- | Generate a random UID of length 8.
---
--- These UIDs are only used for items and categories (because their uids can
--- occur in links and so they should look a bit nicer).
---
--- Probability of collision for
---
---   * a hundred thousand UIDs: approximately 0.5%
---   * a million UIDs: approximately 40%
---
-randomShortUid :: MonadIO m => m (Uid a)
-randomShortUid = Uid <$> randomText 8
-
--- | A marker for Uids that would be used with HTML nodes
-data Node
-
--- | Generate a HTML @id@ attribute from an 'Uid'.
-uid_ :: Uid Node -> Attribute
-uid_ = id_ . uidToText
-
 ----------------------------------------------------------------------------
 -- JSON
 ----------------------------------------------------------------------------

back/src/Guide/Views.hs

@@ -51,6 +51,7 @@ import Guide.State
 import Guide.Types
 import Guide.Utils
 import Guide.Views.Utils
+import Guide.Uid
 
 import qualified CMark as MD
 import qualified Data.Aeson as Aeson
@@ -204,7 +205,7 @@ renderAdmin globalState = do
     script_ $ fromJS $ JS.createAjaxIndicator ()
     h1_ "Miscellaneous"
     buttonUid <- randomLongUid
-    button "Create checkpoint" [uid_ buttonUid] $
+    button "Create checkpoint" [id_ (uidToText buttonUid)] $
       JS.createCheckpoint [JS.selectUid buttonUid]
     div_ [id_ "edits"] $
       renderEdits globalState (map (,Nothing) (pendingEdits globalState))

back/src/Guide/Views/Category.hs

@@ -24,9 +24,9 @@ import Lucid hiding (for_)
 
 import Guide.Markdown
 import Guide.Types.Core
-import Guide.Utils
 import Guide.Views.Item
 import Guide.Views.Utils
+import Guide.Uid
 
 import qualified Data.Text.IO as T
 

back/src/Guide/Views/Item.hs

@@ -31,8 +31,8 @@ import Lucid hiding (for_)
 import Guide.JS (JS (..))
 import Guide.Markdown
 import Guide.Types.Core
-import Guide.Utils
 import Guide.Views.Utils
+import Guide.Uid
 
 import qualified Data.Aeson as Aeson
 import qualified Data.Text.IO as T
@@ -167,7 +167,7 @@ renderItemTraits item = div_ [class_ "item-traits"] $ do
         -- We can't use 'thisNode' inside <ul> because it creates a <span>
         -- and only <li> elements can be children of <ul>
         listUid <- randomLongUid
-        ul_ [uid_ listUid] $
+        ul_ [id_ (uidToText listUid)] $
           mapM_ (renderTrait (itemUid item)) (itemPros item)
         section "editable" [] $ do
           smallMarkdownEditor
@@ -195,7 +195,7 @@ renderItemTraits item = div_ [class_ "item-traits"] $ do
             [style_ "width:12px;opacity:0.5"] $
             JS.switchSectionsEverywhere (this, "normal" :: Text)
         listUid <- randomLongUid
-        ul_ [uid_ listUid] $
+        ul_ [id_ (uidToText listUid)] $
           mapM_ (renderTrait (itemUid item)) (itemCons item)
         section "editable" [] $ do
           smallMarkdownEditor
@@ -293,5 +293,5 @@ renderItemNotes category item = do
       -- the notes are closed (but don't scroll if it's already visible after
       -- the notes have been hidden)
 
-    section "editing" [uid_ editingSectionUid] $
+    section "editing" [id_ (uidToText editingSectionUid)] $
       return ()

back/src/Guide/Views/Utils.hs

@@ -83,6 +83,7 @@ import Guide.JS (JQuerySelector, JS (..))
 import Guide.Markdown
 import Guide.Types
 import Guide.Utils
+import Guide.Uid
 -- import Guide.Config
 -- import Guide.State
 
@@ -195,7 +196,7 @@ markdownEditor
   -> HtmlT m ()
 markdownEditor rows (markdownBlockSource -> src) submit cancel instr = do
   editorUid <- randomLongUid
-  term "a-editor" [uid_ editorUid,
+  term "a-editor" [id_ (uidToText editorUid),
                    vBind "init-content" src,
                    vBind "instruction" instr,
                    vBind "rows" rows,
@@ -216,7 +217,7 @@ smallMarkdownEditor
   -> HtmlT m ()
 smallMarkdownEditor rows (markdownInlineSource -> src) submit mbCancel instr mbPlaceholder = do
   editorUid <- randomLongUid
-  term "a-editor-mini" ([uid_ editorUid,
+  term "a-editor-mini" ([id_ (uidToText editorUid),
                          vBind "init-content" src,
                          vBind "instruction" instr,
                          vBind "rows" rows] ++
@@ -233,7 +234,7 @@ thisNode = do
   uid' <- randomLongUid
   -- If the class name ever changes, fix 'JS.moveNodeUp' and
   -- 'JS.moveNodeDown'.
-  span_ [uid_ uid', class_ "dummy"] mempty
+  span_ [id_ (uidToText uid'), class_ "dummy"] mempty
   return (JS.selectParent (JS.selectUid uid'))
 
 itemNodeId :: Item -> Text

back/tests/ApiSpec.hs

@@ -12,7 +12,7 @@ import Network.HTTP.Types.Status
 -- Site
 import Guide.Api.Types
 import Guide.Types.Core
-import Guide.Utils (Uid (..))
+import Guide.Uid
 -- Tests
 import Test.Hspec