fixing licences to actual datatypes

Foundation.hs

@@ -27,6 +27,7 @@ import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
 import Settings.StaticFiles
 import Settings
 import Model
+import Licence
 import Text.Jasmine (minifym)
 import Text.Hamlet (hamletFile)
 import Yesod.Core.Types
@@ -293,7 +294,7 @@ instance PersistUserCredentials User where
   userUserActiveF = UserActive
   uniqueUsername  = UniqueUser
 
-  userCreate name email salt = User name name email salt "" [] False (-1) False
+  userCreate name email salt = User name name email salt "" [] False AllRightsReserved False
 
 instance PersistToken Token where
   tokenTokenTokenF = TokenToken

Handler/AdminMediumSettings.hs

@@ -103,7 +103,8 @@ adminMediumSetForm medium = Medium
   <*> areq (selectField licenses) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
   <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
   where
-    licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licenses = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
+      [minBound..maxBound]
 
 getAdminMediumDeleteR :: MediumId -> Handler Html
 getAdminMediumDeleteR mediumId = do

Handler/AdminProfileSettings.hs

@@ -142,7 +142,8 @@ adminProfileForm owner = User
   <*> pure (userActive owner)
   <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
   where
-    licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licenses = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
+      [minBound..maxBound]
 
 getAdminProfileDeleteR :: UserId -> Handler Html
 getAdminProfileDeleteR ownerId = do

Handler/Commons.hs

@@ -179,7 +179,7 @@ handleUpload
   -> UserId                 -- ^ 'UserId' of media owner
   -> Maybe Markdown         -- ^ Description text
   -> [T.Text]               -- ^ Tags
-  -> Int                    -- ^ Licence
+  -> Licence                -- ^ Licence
   -> UploadSpec             -- ^ New file or replacement file?
   -> (Int, FileInfo)        -- ^ actual file
   -> Handler (Maybe T.Text) -- ^ Returns the filename if something fails

Handler/Medium.hs

@@ -63,8 +63,8 @@ getMediumR mediumId = do
             (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) []
           ir = StaticR $ StaticRoute
             (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) []
-          lic = T.pack $ show (toEnum (mediumLicence medium) :: Licence)
+          lic = T.pack $ show $ mediumLicence medium
-          link = url (toEnum (mediumLicence medium) :: Licence)
+          link = url $ mediumLicence medium
       defaultLayout $ do
         setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
         rssLink (CommentFeedRssR mediumId) $

Handler/MediumSettings.hs

@@ -85,7 +85,7 @@ data MediumSettings = MediumSettings
   , msData        :: Maybe FileInfo
   , msDescription :: Maybe Markdown
   , msTags        :: [T.Text]
-  , msLicence     :: Int
+  , msLicence     :: Licence
   }
 
 mediumSettingsForm :: Medium -> AForm Handler MediumSettings
@@ -97,7 +97,8 @@ mediumSettingsForm medium = MediumSettings
   <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
   <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
   where
-    licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
+      [minBound..maxBound]
 
 getMediumDeleteR :: MediumId -> Handler Html
 getMediumDeleteR mediumId = do

Handler/ProfileSettings.hs

@@ -73,4 +73,5 @@ profileSettingsForm user = User
   <*> pure (userActive user)
   <*  bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
   where
-    licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
+      [minBound..maxBound]

Handler/RootFeed.hs

@@ -194,7 +194,7 @@ mediumToEntry ent = do
     , feedEntryTitle = mediumTitle (entityVal ent)
     , feedEntryContent = toHtml ((fromMaybe (Markdown "") $ mediumDescription $ entityVal ent)
       `mappend` Markdown (LT.pack "\n\n")
-      `mappend` Markdown (LT.pack $ show $ (toEnum $ mediumLicence (entityVal ent) :: Licence)))
+      `mappend` Markdown (LT.pack $ show $ mediumLicence $ entityVal ent))
     , feedEntryEnclosure = Just $ EntryEnclosure
         (StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview $ entityVal ent) [])
         size

Handler/Upload.hs

@@ -117,7 +117,8 @@ dUploadForm userId user albumId = FileBulk
   <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
   <*  bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
   where
-    licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
+      [minBound..maxBound]
     defLicence = Just $ userDefaultLicence user
 
 
@@ -129,7 +130,7 @@ data FileBulk = FileBulk
   , fileBulkDesc :: Maybe Markdown
   , fileBulkTags :: [T.Text]
   , fileBulkAlbum :: AlbumId
-  , fileBulkLicence :: Int
+  , fileBulkLicence :: Licence
   }
 
 getUploadR :: Handler Html
@@ -174,7 +175,8 @@ bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h)
               else Nothing
             ) allEnts
       optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
-    licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
+    licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
+      [minBound..maxBound]
     defLicence = Just $ userDefaultLicence user
 
 postUploadR :: Handler Html

Import.hs

@@ -36,6 +36,7 @@ import           Settings.StaticFiles as Import
 -- custom imports
 
 import           Helper               as Import
+import           Licence              as Import
 
 -- end custom imports
 

Licence.hs

@@ -0,0 +1,92 @@
+--  eidolon -- A simple gallery in Haskell and Yesod
+--  Copyright (C) 2015  Amedeo Molnár
+--
+--  This program is free software: you can redistribute it and/or modify
+--  it under the terms of the GNU Affero General Public License as published
+--  by the Free Software Foundation, either version 3 of the License, or
+--  (at your option) any later version.
+--
+--  This program is distributed in the hope that it will be useful,
+--  but WITHOUT ANY WARRANTY; without even the implied warranty of
+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+--  GNU Affero General Public License for more details.
+--
+--  You should have received a copy of the GNU Affero General Public License
+--  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+module Licence where
+
+import ClassyPrelude.Yesod
+import Database.Persist.Sql
+import Data.Bits (bitSizeMaybe)
+
+class ShowUrl a where
+  url :: a -> Maybe String
+
+data Licence
+  = PublicDomain
+  | AllRightsReserved
+  | CC0
+  | CCBy4
+  | CCBySa4
+  | CCByNd4
+  | CCByNc4
+  | CCByNcSa4
+  | CCByNcNd4
+  deriving (Eq, Ord, Bounded)
+
+instance ShowUrl Licence where
+  url PublicDomain      = Nothing
+  url AllRightsReserved = Nothing
+  url CC0               = Just "https://creativecommons.org/publicdomain/zero/1.0/"
+  url CCBy4             = Just "https://creativecommons.org/licenses/by/4.0"
+  url CCBySa4           = Just "https://creativecommons.org/licenses/by-sa/4.0"
+  url CCByNd4           = Just "https://creativecommons.org/licenses/by-nd/4.0"
+  url CCByNc4           = Just "https://creativecommons.org/licenses/by-nc/4.0"
+  url CCByNcSa4         = Just "https://creativecommons.org/licenses/by-nc-sa/4.0"
+  url CCByNcNd4         = Just "https://creativecommons.org/licenses/by-nc-nd/4.0"
+
+instance Show Licence where
+  show PublicDomain      = "Public Domain"
+  show AllRightsReserved = "All rights reserved"
+  show CC0               = "CC0 1.0"
+  show CCBy4             = "CC-BY 4.0 International"
+  show CCBySa4           = "CC-BY-SA 4.0 International"
+  show CCByNd4           = "CC-BY-ND 4.0 International"
+  show CCByNc4           = "CC-BY-NC 4.0 International"
+  show CCByNcSa4         = "CC-BY-NC-SA 4.0 International"
+  show CCByNcNd4         = "CC-BY-NC-ND 4.0 International"
+
+instance Enum Licence where
+  fromEnum PublicDomain      = -2
+  fromEnum AllRightsReserved = -1
+  fromEnum CC0               = 0
+  fromEnum CCBy4             = 1
+  fromEnum CCBySa4           = 2
+  fromEnum CCByNd4           = 3
+  fromEnum CCByNc4           = 4
+  fromEnum CCByNcSa4         = 5
+  fromEnum CCByNcNd4         = 6
+  fromEnum n                 = error $ "no licence no. for" ++ show n
+
+  toEnum (-2) = PublicDomain
+  toEnum (-1) = AllRightsReserved
+  toEnum    0 = CC0
+  toEnum    1 = CCBy4
+  toEnum    2 = CCBySa4
+  toEnum    3 = CCByNd4
+  toEnum    4 = CCByNc4
+  toEnum    5 = CCByNcSa4
+  toEnum    6 = CCByNcNd4
+  toEnum n    = error $ "No licence no. " ++ show n
+
+instance PersistField Licence where
+  toPersistValue = PersistInt64 . fromIntegral . fromEnum
+
+  fromPersistValue (PersistInt64 i) = Right $ toEnum $ fromIntegral i
+  fromPersistValue _ = Left "Licence is to be read form PersistInt"
+
+instance PersistFieldSql Licence where
+  sqlType _
+    | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32
+    | otherwise = SqlInt64

Model.hs

@@ -19,8 +19,9 @@ module Model where
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 import Text.Markdown
-import Yesod.Text.Markdown
+import Yesod.Text.Markdown ()
 import qualified System.FilePath as FP
+import Licence
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
@@ -28,62 +29,3 @@ import qualified System.FilePath as FP
 -- http://www.yesodweb.com/book/persistent/
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")
-
-class ShowUrl a where
-  url :: a -> Maybe String
-
-data Licence
-  = AllRightsReserved
-  | CC0
-  | CCBy4
-  | CCBySa4
-  | CCByNd4
-  | CCByNc4
-  | CCByNcSa4
-  | CCByNcNd4
-  | PublicDomain
-
-instance ShowUrl Licence where
-  url PublicDomain      = Nothing
-  url AllRightsReserved = Nothing
-  url CC0               = Just "https://creativecommons.org/publicdomain/zero/1.0/"
-  url CCBy4             = Just "https://creativecommons.org/licenses/by/4.0"
-  url CCBySa4           = Just "https://creativecommons.org/licenses/by-sa/4.0"
-  url CCByNd4           = Just "https://creativecommons.org/licenses/by-nd/4.0"
-  url CCByNc4           = Just "https://creativecommons.org/licenses/by-nc/4.0"
-  url CCByNcSa4         = Just "https://creativecommons.org/licenses/by-nc-sa/4.0"
-  url CCByNcNd4         = Just "https://creativecommons.org/licenses/by-nc-nd/4.0"
-
-instance Show Licence where
-  show PublicDomain      = "Public Domain"
-  show AllRightsReserved = "All rights reserved"
-  show CC0               = "CC0 1.0"
-  show CCBy4             = "CC-BY 4.0 International"
-  show CCBySa4           = "CC-BY-SA 4.0 International"
-  show CCByNd4           = "CC-BY-ND 4.0 International"
-  show CCByNc4           = "CC-BY-NC 4.0 International"
-  show CCByNcSa4         = "CC-BY-NC-SA 4.0 International"
-  show CCByNcNd4         = "CC-BY-NC-ND 4.0 International"
-
-instance Enum Licence where
-  fromEnum PublicDomain      = -2
-  fromEnum AllRightsReserved = -1
-  fromEnum CC0               = 0
-  fromEnum CCBy4             = 1
-  fromEnum CCBySa4           = 2
-  fromEnum CCByNd4           = 3
-  fromEnum CCByNc4           = 4
-  fromEnum CCByNcSa4         = 5
-  fromEnum CCByNcNd4         = 6
-  fromEnum n                 = error $ "no licence no. for" ++ show n
-
-  toEnum (-2) = PublicDomain
-  toEnum (-1) = AllRightsReserved
-  toEnum    0 = CC0
-  toEnum    1 = CCBy4
-  toEnum    2 = CCBySa4
-  toEnum    3 = CCByNd4
-  toEnum    4 = CCByNc4
-  toEnum    5 = CCByNcSa4
-  toEnum    6 = CCByNcNd4
-  toEnum n    = error $ "No licence no. " ++ show n

config/models

@@ -22,7 +22,7 @@ User
     salted ByteString
     albums [AlbumId]
     admin Bool
-    defaultLicence Int		default=-1
+    defaultLicence Licence	default=-1
     active Bool			default=True
     UniqueUser name
     deriving Typeable Eq Show
@@ -54,7 +54,7 @@ Medium
     tags Texts
     album AlbumId
     preview FP.FilePath
-    licence Int			default=-1
+    licence Licence			default=-1
     deriving Eq Show
 Comment
     author UserId

eidolon.cabal

@@ -26,6 +26,7 @@ library
     exposed-modules: Application
                      Foundation
                      Helper
+                     Licence
                      Import
                      Model
                      Scale