From 452d64dcb6cf0fecbd88a7c5369ff9def581a9b5 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 21 Aug 2019 23:16:18 +0200 Subject: [PATCH 01/73] Add people basic queries --- app/Main.hs | 4 +-- package.yaml | 3 ++ src/Database.hs | 83 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Lib.hs | 6 ---- stack.yaml | 2 ++ 5 files changed, 90 insertions(+), 8 deletions(-) create mode 100644 src/Database.hs delete mode 100644 src/Lib.hs diff --git a/app/Main.hs b/app/Main.hs index de1c1ab..4f30b16 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main where -import Lib +import Database main :: IO () -main = someFunc +main = putStrLn "main" diff --git a/package.yaml b/package.yaml index d6c6173..8a2ae7c 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,9 @@ dependencies: - Spock >= 0.11 - mtl - text +- postgresql-simple +- bytestring +- scientific library: source-dirs: src diff --git a/src/Database.hs b/src/Database.hs new file mode 100644 index 0000000..2bca0a6 --- /dev/null +++ b/src/Database.hs @@ -0,0 +1,83 @@ +-- |Module used for connecting to the database +{-# LANGUAGE OverloadedStrings #-} +module Database where + +import Data.Text +import Data.Int (Int64) +import Data.ByteString (ByteString) +import Data.Scientific +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToRow + +-- costants +uri :: ByteString +uri = "postgres://postgres:14102002@localhost/FabLab" + +newPersonString :: Query +newPersonString = "INSERT INTO persone (cf, nome, cognome, socio, operatore_intagliatrice, operatore_stampante, spesa_totale) \ + \ values (?, ?, ?, ?, ?, ?, ?)" + +changePersonStatusString :: Query +changePersonStatusString = "UPDATE persone SET socio = ?, operatore_intagliatrice = ?, operatore_stampante = ? WHERE cf = ?" + +increasePersonExpenseString :: Query +increasePersonExpenseString = "UPDATE persone SET spesa_totale = spesa_totale + ? where cf = ?" + +-- datatypes +-- |Data representing a person in the database +data Person = Person { cf :: Text + , nome :: Text + , cognome :: Text + , socio :: Bool + , operatoreIntagliatrice :: Bool + , operatoreStampante :: Bool + , spesaTotale :: Scientific + } deriving (Show) +instance Eq Person where + (==) p p' = (cf p) == (cf p') +instance FromRow Person where + fromRow = Person <$> field <*> field <*> field <*> field <*> field <*> field <*> field +instance ToRow Person where + toRow p = [ toField (cf p) + , toField (nome p) + , toField (cognome p) + , toField (socio p) + , toField (operatoreIntagliatrice p) + , toField (operatoreStampante p) + , toField (spesaTotale p) + ] + +-- miscellaneus functions +validateLength :: Int -> String -> Maybe String +validateLength n s = if Prelude.length s == n then Just s else Nothing + +mkPerson :: String -> String -> String -> Maybe Person +mkPerson cf nome cognome = Person <$> (pack <$> validateLength 16 cf) + <*> (pack <$> validateLength 30 nome) + <*> (pack <$> validateLength 30 cognome) + <*> Just False + <*> Just False + <*> Just False + <*> Just 0 + +changePersonStatus :: Person -> Bool -> Bool -> Bool -> Person +changePersonStatus p socio opIntagliatrice opStampante = Person (cf p) (nome p) (cognome p) socio opIntagliatrice opStampante (spesaTotale p) + +-- people queries +-- |Function to add a person to the database using the given connection +addPerson :: Connection -> Person -> IO Int64 +addPerson conn person = execute conn newPersonString person + +-- |Function to modify a person status in the database, updating it to the one of the given Person, using the given connection +modifyPersonStatus :: Connection -> Person -> IO Int64 +modifyPersonStatus conn updatedPerson = + execute conn changePersonStatusString ( socio updatedPerson + , operatoreIntagliatrice updatedPerson + , operatoreStampante updatedPerson + , cf updatedPerson) + +-- |Function to increase the total expense of the given person, using the given connection +increasePersonExpense :: Connection -> Person -> Double -> IO Int64 +increasePersonExpense conn person increment = execute conn increasePersonExpenseString (increment, (cf person)) \ No newline at end of file diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff27..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/stack.yaml b/stack.yaml index f2879ca..2fbaddb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,6 +43,8 @@ extra-deps: - Spock-0.13.0.0 - Spock-core-0.13.0.0 - reroute-0.5.0.0 +- stm-containers-0.2.16 +- focus-0.1.5.2 # Override default flag values for local packages and extra-deps # flags: {} From 7a340ea940f5290768376dd7c381d1117a8aa2d0 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 2 Sep 2019 21:13:04 +0200 Subject: [PATCH 02/73] Change db interface library, implement db datatypes --- .gitignore | 3 +- package.yaml | 4 +- src/Database.hs | 304 ++++++++++++++++++++++++++++++++++++++---------- 3 files changed, 245 insertions(+), 66 deletions(-) diff --git a/.gitignore b/.gitignore index 7cdb778..efe515a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ .stack-work/ haskellDB.cabal -*~ \ No newline at end of file +*~ +*.lock \ No newline at end of file diff --git a/package.yaml b/package.yaml index 8a2ae7c..e1f5903 100644 --- a/package.yaml +++ b/package.yaml @@ -24,9 +24,11 @@ dependencies: - Spock >= 0.11 - mtl - text -- postgresql-simple +- beam-core +- beam-postgres - bytestring - scientific +- time library: source-dirs: src diff --git a/src/Database.hs b/src/Database.hs index 2bca0a6..312c67f 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -1,83 +1,259 @@ -- |Module used for connecting to the database {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} module Database where import Data.Text import Data.Int (Int64) import Data.ByteString (ByteString) import Data.Scientific -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.FromRow -import Database.PostgreSQL.Simple.ToRow +import Data.Time.Calendar +import Database.Beam +import Database.Beam.Postgres -- costants uri :: ByteString uri = "postgres://postgres:14102002@localhost/FabLab" -newPersonString :: Query -newPersonString = "INSERT INTO persone (cf, nome, cognome, socio, operatore_intagliatrice, operatore_stampante, spesa_totale) \ - \ values (?, ?, ?, ?, ?, ?, ?)" - -changePersonStatusString :: Query -changePersonStatusString = "UPDATE persone SET socio = ?, operatore_intagliatrice = ?, operatore_stampante = ? WHERE cf = ?" - -increasePersonExpenseString :: Query -increasePersonExpenseString = "UPDATE persone SET spesa_totale = spesa_totale + ? where cf = ?" +runBeam :: (String -> IO ()) -> Connection -> Pg a -> IO a +runBeam = runBeamPostgresDebug -- change for debug or production purposes -- datatypes -- |Data representing a person in the database -data Person = Person { cf :: Text - , nome :: Text - , cognome :: Text - , socio :: Bool - , operatoreIntagliatrice :: Bool - , operatoreStampante :: Bool - , spesaTotale :: Scientific - } deriving (Show) -instance Eq Person where - (==) p p' = (cf p) == (cf p') -instance FromRow Person where - fromRow = Person <$> field <*> field <*> field <*> field <*> field <*> field <*> field -instance ToRow Person where - toRow p = [ toField (cf p) - , toField (nome p) - , toField (cognome p) - , toField (socio p) - , toField (operatoreIntagliatrice p) - , toField (operatoreStampante p) - , toField (spesaTotale p) - ] - --- miscellaneus functions -validateLength :: Int -> String -> Maybe String -validateLength n s = if Prelude.length s == n then Just s else Nothing - -mkPerson :: String -> String -> String -> Maybe Person -mkPerson cf nome cognome = Person <$> (pack <$> validateLength 16 cf) - <*> (pack <$> validateLength 30 nome) - <*> (pack <$> validateLength 30 cognome) - <*> Just False - <*> Just False - <*> Just False - <*> Just 0 - -changePersonStatus :: Person -> Bool -> Bool -> Bool -> Person -changePersonStatus p socio opIntagliatrice opStampante = Person (cf p) (nome p) (cognome p) socio opIntagliatrice opStampante (spesaTotale p) +data PersonT f = Person { _personCf :: Columnar f Text + , _personNome :: Columnar f Text + , _personCognome :: Columnar f Text + , _personSocio :: Columnar f Bool + , _personOperatoreIntagliatrice :: Columnar f Bool + , _personOperatoreStampante :: Columnar f Bool + , _personSpesaTotale :: Columnar f Scientific + } deriving (Beamable, Generic) +instance Table PersonT where + data PrimaryKey PersonT f = PersonId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = PersonId . _personCf +type Person = PersonT Identity +type PersonId = PrimaryKey PersonT Identity +deriving instance Eq Person +deriving instance Show Person +deriving instance Eq PersonId +deriving instance Show PersonId +deriving instance Eq (PrimaryKey PersonT (Nullable Identity)) +deriving instance Show (PrimaryKey PersonT (Nullable Identity)) + +-- |Data representing a print +data PrintT f = Print { _printCodiceStampa :: Columnar f Integer + , _printDataRichiesta :: Columnar f Day + , _printDataConsegna :: Columnar f (Maybe Day) + , _printTempo :: Columnar f (Maybe Double) + , _printCostoMateriali :: Columnar f (Maybe Scientific) + , _printCostoTotale :: Columnar f (Maybe Scientific) + , _printDescrizione :: Columnar f Text + , _printCfRichiedente :: PrimaryKey PersonT f + , _printCfIncaricato :: PrimaryKey PersonT (Nullable f) + , _printCodiceStampante :: PrimaryKey PrinterT (Nullable f) + } deriving (Beamable, Generic) +instance Table PrintT where + data PrimaryKey PrintT f = PrintId (Columnar f Integer) deriving (Beamable, Generic) + primaryKey = PrintId . _printCodiceStampa +type Print = PrintT Identity +type PrintId = PrimaryKey PrintT Identity +deriving instance Eq Print +deriving instance Show Print +deriving instance Eq PrintId +deriving instance Show PrintId + +-- |Data representing a cut +data CutT f = Cut { _cutCodiceIntaglio :: Columnar f Integer + , _cutDataRichiesta :: Columnar f Day + , _cutDataConsegna :: Columnar f (Maybe Day) + , _cutTempo :: Columnar f (Maybe Double) + , _cutCostoMateriali :: Columnar f (Maybe Scientific) + , _cutCostoTotale :: Columnar f (Maybe Scientific) + , _cutDescrizione :: Columnar f Text + , _cutCfRichiedente :: PrimaryKey PersonT f + , _cutCfIncaricato :: PrimaryKey PersonT (Nullable f) + } deriving (Beamable, Generic) +instance Table CutT where + data PrimaryKey CutT f = CutId (Columnar f Integer) deriving (Beamable, Generic) + primaryKey = CutId . _cutCodiceIntaglio +type Cut = CutT Identity +type CutId = PrimaryKey CutT Identity +deriving instance Eq Cut +deriving instance Show Cut +deriving instance Eq CutId +deriving instance Show CutId + +-- |Data representing a printer +data PrinterT f = Printer { _printerCodiceStampante :: Columnar f Text + , _printerMarca :: Columnar f Text + , _printerModello :: Columnar f Text + , _printerDescrizione :: Columnar f Text + } deriving (Beamable, Generic) +instance Table PrinterT where + data PrimaryKey PrinterT f = PrinterId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = PrinterId . _printerCodiceStampante +type Printer = PrinterT Identity +type PrinterId = PrimaryKey PrinterT Identity +deriving instance Eq Printer +deriving instance Show Printer +deriving instance Eq PrinterId +deriving instance Show PrinterId +deriving instance Eq (PrimaryKey PrinterT (Nullable Identity)) +deriving instance Show (PrimaryKey PrinterT (Nullable Identity)) + +-- |Data representing a type of plastic +data PlasticT f = Plastic { _plasticCodicePlastica :: Columnar f Text + , _plasticNome :: Columnar f Text + , _plasticDescrizione :: Columnar f Text + } deriving (Beamable, Generic) +instance Table PlasticT where + data PrimaryKey PlasticT f = PlasticId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = PlasticId . _plasticCodicePlastica +type Plastic = PlasticT Identity +type PlasticId = PrimaryKey PlasticT Identity +deriving instance Eq Plastic +deriving instance Show Plastic +deriving instance Eq PlasticId +deriving instance Show PlasticId + +-- |Data representing a filament +data FilamentT f = Filament { _filamentCodiceFilamento :: Columnar f Text + , _filamentCodicePlastica :: PrimaryKey PlasticT f + , _filamentMarca :: Columnar f Text + , _filamentColore :: Columnar f Text + } deriving (Beamable, Generic) +instance Table FilamentT where + data PrimaryKey FilamentT f = FilamentId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = FilamentId . _filamentCodiceFilamento +type Filament = FilamentT Identity +type FilamentId = PrimaryKey FilamentT Identity +deriving instance Eq Filament +deriving instance Show Filament +deriving instance Eq FilamentId +deriving instance Show FilamentId + +-- |Data representing a way of executing a cut +data ProcessingT f = Processing { _processingCodiceTipo :: PrimaryKey TypeT f + , _processingCodiceLavorazione :: Columnar f Text + , _processingCodiceMateriale :: PrimaryKey MaterialT f + , _processingPotenzaMassima :: Columnar f Text + , _processingPotenzaMinima :: Columnar f Text + , _processingVelocita :: Columnar f Text + , _processingDescrizione :: Columnar f Text + } deriving (Beamable, Generic) +instance Table ProcessingT where + data PrimaryKey ProcessingT f = ProcessingId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = ProcessingId . _processingCodiceLavorazione +type Processing = ProcessingT Identity +type ProcessingId = PrimaryKey ProcessingT Identity +deriving instance Eq Processing +deriving instance Show Processing +deriving instance Eq ProcessingId +deriving instance Show ProcessingId + +-- |Data representing a type of processing +data TypeT f = Type { _typeCodiceTipo :: Columnar f Text + , _typeNome :: Columnar f Text + , _typeDescrizione :: Columnar f Text + } deriving (Beamable, Generic) +instance Table TypeT where + data PrimaryKey TypeT f = TypeId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = TypeId . _typeCodiceTipo +type Type = TypeT Identity +type TypeId = PrimaryKey TypeT Identity +deriving instance Eq Type +deriving instance Show Type +deriving instance Eq TypeId +deriving instance Show TypeId + +-- |Data representing a material +data MaterialT f = Material { _materialCodiceClasse :: PrimaryKey MaterialsClassT f + , _materialCodiceMateriale :: Columnar f Text + , _materialNome :: Columnar f Text + , _materialSpessore :: Columnar f Double + , _materialDescrizione :: Columnar f Text + } deriving (Beamable, Generic) +instance Table MaterialT where + data PrimaryKey MaterialT f = MaterialId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = MaterialId . _materialCodiceMateriale +type Material = MaterialT Identity +type MaterialId = PrimaryKey MaterialT Identity +deriving instance Eq Material +deriving instance Show Material +deriving instance Eq MaterialId +deriving instance Show MaterialId + +-- |Data representing a class of materials +data MaterialsClassT f = MaterialsClass { _materialsclassCodiceClasse :: Columnar f Text + , _materialsclassNome :: Columnar f Text + } deriving (Beamable, Generic) +instance Table MaterialsClassT where + data PrimaryKey MaterialsClassT f = MaterialsClassId (Columnar f Text) deriving (Beamable, Generic) + primaryKey = MaterialsClassId . _materialsclassCodiceClasse +type MaterialsClass = MaterialsClassT Identity +type MaterialsClassId = PrimaryKey MaterialsClassT Identity +deriving instance Eq MaterialsClass +deriving instance Show MaterialsClass +deriving instance Eq MaterialsClassId +deriving instance Show MaterialsClassId + +-- |Data representing a processing used in a cut +data CompositionT f = Composition { _compositionCodiceLavorazione :: PrimaryKey ProcessingT f + , _compositionCodiceIntaglio :: PrimaryKey CutT f + } deriving (Beamable, Generic) +instance Table CompositionT where + data PrimaryKey CompositionT f = CompositionId (PrimaryKey ProcessingT f) (PrimaryKey CutT f) deriving (Beamable, Generic) + primaryKey = CompositionId <$> _compositionCodiceLavorazione <*> _compositionCodiceIntaglio +type Composition = CompositionT Identity +type CompositionId = PrimaryKey CompositionT Identity +deriving instance Eq Composition +deriving instance Show Composition +deriving instance Eq CompositionId +deriving instance Show CompositionId + +-- |Data representing a filament used in a print +data UseT f = Use { _useCodiceFilamento :: PrimaryKey FilamentT f + , _useCodiceStampa :: PrimaryKey PrintT f + } deriving (Beamable, Generic) +instance Table UseT where + data PrimaryKey UseT f = UseId (PrimaryKey FilamentT f) (PrimaryKey PrintT f) deriving (Beamable, Generic) + primaryKey = UseId <$> _useCodiceFilamento <*> _useCodiceStampa +type Use = UseT Identity +type UseId = PrimaryKey UseT Identity +deriving instance Eq Use +deriving instance Show Use +deriving instance Eq UseId +deriving instance Show UseId + +-- |Data representing the database +data FabLabDB f = FabLabDB { _persone :: f (TableEntity PersonT) + , _stampe :: f (TableEntity PrintT) + , _classi_di_materiali :: f (TableEntity MaterialsClassT) + } deriving (Database be, Generic) + +fabLabDB :: DatabaseSettings be FabLabDB +fabLabDB = defaultDbSettings -- people queries -- |Function to add a person to the database using the given connection -addPerson :: Connection -> Person -> IO Int64 -addPerson conn person = execute conn newPersonString person - --- |Function to modify a person status in the database, updating it to the one of the given Person, using the given connection -modifyPersonStatus :: Connection -> Person -> IO Int64 -modifyPersonStatus conn updatedPerson = - execute conn changePersonStatusString ( socio updatedPerson - , operatoreIntagliatrice updatedPerson - , operatoreStampante updatedPerson - , cf updatedPerson) - --- |Function to increase the total expense of the given person, using the given connection -increasePersonExpense :: Connection -> Person -> Double -> IO Int64 -increasePersonExpense conn person increment = execute conn increasePersonExpenseString (increment, (cf person)) \ No newline at end of file +insertPerson :: String -> String -> String -> IO () +insertPerson cf name surname = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runInsert $ insert (_persone fabLabDB) $ insertValues [ Person (pack cf) (pack name) (pack surname) False False False 0.0 ] + +-- materials queries +-- |Function to add a person to the database using the given connection +insertMaterialsClass :: String -> String -> IO () +insertMaterialsClass code name = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runInsert $ insert (_classi_di_materiali fabLabDB) $ insertValues [ MaterialsClass (pack code) (pack name) ] \ No newline at end of file From 4eb5da5a5ef97649c04cce53fffcb71ae8cc3234 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 2 Sep 2019 22:26:44 +0200 Subject: [PATCH 03/73] Add people queries --- src/Database.hs | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/src/Database.hs b/src/Database.hs index 312c67f..2b4886b 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -20,6 +20,7 @@ import Data.Scientific import Data.Time.Calendar import Database.Beam import Database.Beam.Postgres +import Database.Beam.Query -- costants uri :: ByteString @@ -28,6 +29,9 @@ uri = "postgres://postgres:14102002@localhost/FabLab" runBeam :: (String -> IO ()) -> Connection -> Pg a -> IO a runBeam = runBeamPostgresDebug -- change for debug or production purposes +allPeople :: Q Postgres FabLabDB s (PersonT (QExpr Postgres s)) +allPeople = all_ (_persone fabLabDB) + -- datatypes -- |Data representing a person in the database data PersonT f = Person { _personCf :: Columnar f Text @@ -238,21 +242,58 @@ deriving instance Show UseId -- |Data representing the database data FabLabDB f = FabLabDB { _persone :: f (TableEntity PersonT) , _stampe :: f (TableEntity PrintT) + , _intagli :: f (TableEntity CutT) + , _stampanti :: f (TableEntity PrinterT) + , _plastiche :: f (TableEntity PlasticT) + , _filamenti :: f (TableEntity FilamentT) + , _lavorazioni :: f (TableEntity ProcessingT) + , _tipi :: f (TableEntity TypeT) + , _materials :: f (TableEntity MaterialT) , _classi_di_materiali :: f (TableEntity MaterialsClassT) + , _composizioni :: f (TableEntity CompositionT) + , _usi :: f (TableEntity UseT) } deriving (Database be, Generic) fabLabDB :: DatabaseSettings be FabLabDB fabLabDB = defaultDbSettings -- people queries --- |Function to add a person to the database using the given connection +-- |Select all people in the database +selectAllPeople :: IO [Person] +selectAllPeople = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runSelectReturningList $ select allPeople + +-- |Select all laser cutter operators in the database +selectLaserCutterOperators :: IO [Person] +selectLaserCutterOperators = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) allPeople + +-- |Select all 3D printer operators in the database +selectPrinterOperators :: IO [Person] +selectPrinterOperators = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) allPeople + +-- |Function to add a person to the database insertPerson :: String -> String -> String -> IO () insertPerson cf name surname = do conn <- connectPostgreSQL uri runBeam putStrLn conn $ runInsert $ insert (_persone fabLabDB) $ insertValues [ Person (pack cf) (pack name) (pack surname) False False False 0.0 ] +-- |Function to modify a person already in the database +modifyPerson :: String -> Bool -> Bool -> Bool -> IO () +modifyPerson cf partner cutter printer = do + conn <- connectPostgreSQL uri + runBeam putStrLn conn $ runUpdate $ update (_persone fabLabDB) + (\p -> mconcat [ _personSocio p <-. (val_ partner) + , _personOperatoreIntagliatrice p <-. (val_ cutter) + , _personOperatoreStampante p <-. (val_ printer) ]) + (\p -> _personCf p ==. (val_ (pack cf))) + -- materials queries --- |Function to add a person to the database using the given connection +-- |Function to add a person to the database insertMaterialsClass :: String -> String -> IO () insertMaterialsClass code name = do conn <- connectPostgreSQL uri From 8afaac7d373d641015973301c16ef06f5c307f12 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 5 Sep 2019 19:39:22 +0200 Subject: [PATCH 04/73] Split Database.hs into Schema.hs and Query.hs, add some queries --- app/Main.hs | 3 +- package.yaml | 3 +- src/Database.hs | 300 ---------------------------------- src/Query.hs | 323 ++++++++++++++++++++++++++++++++++++ src/Schema.hs | 423 ++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 750 insertions(+), 302 deletions(-) delete mode 100644 src/Database.hs create mode 100644 src/Query.hs create mode 100644 src/Schema.hs diff --git a/app/Main.hs b/app/Main.hs index 4f30b16..af39698 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ module Main where -import Database +import Schema +import Query main :: IO () main = putStrLn "main" diff --git a/package.yaml b/package.yaml index e1f5903..699e416 100644 --- a/package.yaml +++ b/package.yaml @@ -24,9 +24,10 @@ dependencies: - Spock >= 0.11 - mtl - text -- beam-core +- beam-core - beam-postgres - bytestring +- utf8-string - scientific - time diff --git a/src/Database.hs b/src/Database.hs deleted file mode 100644 index 2b4886b..0000000 --- a/src/Database.hs +++ /dev/null @@ -1,300 +0,0 @@ --- |Module used for connecting to the database -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveAnyClass #-} -module Database where - -import Data.Text -import Data.Int (Int64) -import Data.ByteString (ByteString) -import Data.Scientific -import Data.Time.Calendar -import Database.Beam -import Database.Beam.Postgres -import Database.Beam.Query - --- costants -uri :: ByteString -uri = "postgres://postgres:14102002@localhost/FabLab" - -runBeam :: (String -> IO ()) -> Connection -> Pg a -> IO a -runBeam = runBeamPostgresDebug -- change for debug or production purposes - -allPeople :: Q Postgres FabLabDB s (PersonT (QExpr Postgres s)) -allPeople = all_ (_persone fabLabDB) - --- datatypes --- |Data representing a person in the database -data PersonT f = Person { _personCf :: Columnar f Text - , _personNome :: Columnar f Text - , _personCognome :: Columnar f Text - , _personSocio :: Columnar f Bool - , _personOperatoreIntagliatrice :: Columnar f Bool - , _personOperatoreStampante :: Columnar f Bool - , _personSpesaTotale :: Columnar f Scientific - } deriving (Beamable, Generic) -instance Table PersonT where - data PrimaryKey PersonT f = PersonId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = PersonId . _personCf -type Person = PersonT Identity -type PersonId = PrimaryKey PersonT Identity -deriving instance Eq Person -deriving instance Show Person -deriving instance Eq PersonId -deriving instance Show PersonId -deriving instance Eq (PrimaryKey PersonT (Nullable Identity)) -deriving instance Show (PrimaryKey PersonT (Nullable Identity)) - --- |Data representing a print -data PrintT f = Print { _printCodiceStampa :: Columnar f Integer - , _printDataRichiesta :: Columnar f Day - , _printDataConsegna :: Columnar f (Maybe Day) - , _printTempo :: Columnar f (Maybe Double) - , _printCostoMateriali :: Columnar f (Maybe Scientific) - , _printCostoTotale :: Columnar f (Maybe Scientific) - , _printDescrizione :: Columnar f Text - , _printCfRichiedente :: PrimaryKey PersonT f - , _printCfIncaricato :: PrimaryKey PersonT (Nullable f) - , _printCodiceStampante :: PrimaryKey PrinterT (Nullable f) - } deriving (Beamable, Generic) -instance Table PrintT where - data PrimaryKey PrintT f = PrintId (Columnar f Integer) deriving (Beamable, Generic) - primaryKey = PrintId . _printCodiceStampa -type Print = PrintT Identity -type PrintId = PrimaryKey PrintT Identity -deriving instance Eq Print -deriving instance Show Print -deriving instance Eq PrintId -deriving instance Show PrintId - --- |Data representing a cut -data CutT f = Cut { _cutCodiceIntaglio :: Columnar f Integer - , _cutDataRichiesta :: Columnar f Day - , _cutDataConsegna :: Columnar f (Maybe Day) - , _cutTempo :: Columnar f (Maybe Double) - , _cutCostoMateriali :: Columnar f (Maybe Scientific) - , _cutCostoTotale :: Columnar f (Maybe Scientific) - , _cutDescrizione :: Columnar f Text - , _cutCfRichiedente :: PrimaryKey PersonT f - , _cutCfIncaricato :: PrimaryKey PersonT (Nullable f) - } deriving (Beamable, Generic) -instance Table CutT where - data PrimaryKey CutT f = CutId (Columnar f Integer) deriving (Beamable, Generic) - primaryKey = CutId . _cutCodiceIntaglio -type Cut = CutT Identity -type CutId = PrimaryKey CutT Identity -deriving instance Eq Cut -deriving instance Show Cut -deriving instance Eq CutId -deriving instance Show CutId - --- |Data representing a printer -data PrinterT f = Printer { _printerCodiceStampante :: Columnar f Text - , _printerMarca :: Columnar f Text - , _printerModello :: Columnar f Text - , _printerDescrizione :: Columnar f Text - } deriving (Beamable, Generic) -instance Table PrinterT where - data PrimaryKey PrinterT f = PrinterId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = PrinterId . _printerCodiceStampante -type Printer = PrinterT Identity -type PrinterId = PrimaryKey PrinterT Identity -deriving instance Eq Printer -deriving instance Show Printer -deriving instance Eq PrinterId -deriving instance Show PrinterId -deriving instance Eq (PrimaryKey PrinterT (Nullable Identity)) -deriving instance Show (PrimaryKey PrinterT (Nullable Identity)) - --- |Data representing a type of plastic -data PlasticT f = Plastic { _plasticCodicePlastica :: Columnar f Text - , _plasticNome :: Columnar f Text - , _plasticDescrizione :: Columnar f Text - } deriving (Beamable, Generic) -instance Table PlasticT where - data PrimaryKey PlasticT f = PlasticId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = PlasticId . _plasticCodicePlastica -type Plastic = PlasticT Identity -type PlasticId = PrimaryKey PlasticT Identity -deriving instance Eq Plastic -deriving instance Show Plastic -deriving instance Eq PlasticId -deriving instance Show PlasticId - --- |Data representing a filament -data FilamentT f = Filament { _filamentCodiceFilamento :: Columnar f Text - , _filamentCodicePlastica :: PrimaryKey PlasticT f - , _filamentMarca :: Columnar f Text - , _filamentColore :: Columnar f Text - } deriving (Beamable, Generic) -instance Table FilamentT where - data PrimaryKey FilamentT f = FilamentId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = FilamentId . _filamentCodiceFilamento -type Filament = FilamentT Identity -type FilamentId = PrimaryKey FilamentT Identity -deriving instance Eq Filament -deriving instance Show Filament -deriving instance Eq FilamentId -deriving instance Show FilamentId - --- |Data representing a way of executing a cut -data ProcessingT f = Processing { _processingCodiceTipo :: PrimaryKey TypeT f - , _processingCodiceLavorazione :: Columnar f Text - , _processingCodiceMateriale :: PrimaryKey MaterialT f - , _processingPotenzaMassima :: Columnar f Text - , _processingPotenzaMinima :: Columnar f Text - , _processingVelocita :: Columnar f Text - , _processingDescrizione :: Columnar f Text - } deriving (Beamable, Generic) -instance Table ProcessingT where - data PrimaryKey ProcessingT f = ProcessingId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = ProcessingId . _processingCodiceLavorazione -type Processing = ProcessingT Identity -type ProcessingId = PrimaryKey ProcessingT Identity -deriving instance Eq Processing -deriving instance Show Processing -deriving instance Eq ProcessingId -deriving instance Show ProcessingId - --- |Data representing a type of processing -data TypeT f = Type { _typeCodiceTipo :: Columnar f Text - , _typeNome :: Columnar f Text - , _typeDescrizione :: Columnar f Text - } deriving (Beamable, Generic) -instance Table TypeT where - data PrimaryKey TypeT f = TypeId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = TypeId . _typeCodiceTipo -type Type = TypeT Identity -type TypeId = PrimaryKey TypeT Identity -deriving instance Eq Type -deriving instance Show Type -deriving instance Eq TypeId -deriving instance Show TypeId - --- |Data representing a material -data MaterialT f = Material { _materialCodiceClasse :: PrimaryKey MaterialsClassT f - , _materialCodiceMateriale :: Columnar f Text - , _materialNome :: Columnar f Text - , _materialSpessore :: Columnar f Double - , _materialDescrizione :: Columnar f Text - } deriving (Beamable, Generic) -instance Table MaterialT where - data PrimaryKey MaterialT f = MaterialId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = MaterialId . _materialCodiceMateriale -type Material = MaterialT Identity -type MaterialId = PrimaryKey MaterialT Identity -deriving instance Eq Material -deriving instance Show Material -deriving instance Eq MaterialId -deriving instance Show MaterialId - --- |Data representing a class of materials -data MaterialsClassT f = MaterialsClass { _materialsclassCodiceClasse :: Columnar f Text - , _materialsclassNome :: Columnar f Text - } deriving (Beamable, Generic) -instance Table MaterialsClassT where - data PrimaryKey MaterialsClassT f = MaterialsClassId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = MaterialsClassId . _materialsclassCodiceClasse -type MaterialsClass = MaterialsClassT Identity -type MaterialsClassId = PrimaryKey MaterialsClassT Identity -deriving instance Eq MaterialsClass -deriving instance Show MaterialsClass -deriving instance Eq MaterialsClassId -deriving instance Show MaterialsClassId - --- |Data representing a processing used in a cut -data CompositionT f = Composition { _compositionCodiceLavorazione :: PrimaryKey ProcessingT f - , _compositionCodiceIntaglio :: PrimaryKey CutT f - } deriving (Beamable, Generic) -instance Table CompositionT where - data PrimaryKey CompositionT f = CompositionId (PrimaryKey ProcessingT f) (PrimaryKey CutT f) deriving (Beamable, Generic) - primaryKey = CompositionId <$> _compositionCodiceLavorazione <*> _compositionCodiceIntaglio -type Composition = CompositionT Identity -type CompositionId = PrimaryKey CompositionT Identity -deriving instance Eq Composition -deriving instance Show Composition -deriving instance Eq CompositionId -deriving instance Show CompositionId - --- |Data representing a filament used in a print -data UseT f = Use { _useCodiceFilamento :: PrimaryKey FilamentT f - , _useCodiceStampa :: PrimaryKey PrintT f - } deriving (Beamable, Generic) -instance Table UseT where - data PrimaryKey UseT f = UseId (PrimaryKey FilamentT f) (PrimaryKey PrintT f) deriving (Beamable, Generic) - primaryKey = UseId <$> _useCodiceFilamento <*> _useCodiceStampa -type Use = UseT Identity -type UseId = PrimaryKey UseT Identity -deriving instance Eq Use -deriving instance Show Use -deriving instance Eq UseId -deriving instance Show UseId - --- |Data representing the database -data FabLabDB f = FabLabDB { _persone :: f (TableEntity PersonT) - , _stampe :: f (TableEntity PrintT) - , _intagli :: f (TableEntity CutT) - , _stampanti :: f (TableEntity PrinterT) - , _plastiche :: f (TableEntity PlasticT) - , _filamenti :: f (TableEntity FilamentT) - , _lavorazioni :: f (TableEntity ProcessingT) - , _tipi :: f (TableEntity TypeT) - , _materials :: f (TableEntity MaterialT) - , _classi_di_materiali :: f (TableEntity MaterialsClassT) - , _composizioni :: f (TableEntity CompositionT) - , _usi :: f (TableEntity UseT) - } deriving (Database be, Generic) - -fabLabDB :: DatabaseSettings be FabLabDB -fabLabDB = defaultDbSettings - --- people queries --- |Select all people in the database -selectAllPeople :: IO [Person] -selectAllPeople = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runSelectReturningList $ select allPeople - --- |Select all laser cutter operators in the database -selectLaserCutterOperators :: IO [Person] -selectLaserCutterOperators = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) allPeople - --- |Select all 3D printer operators in the database -selectPrinterOperators :: IO [Person] -selectPrinterOperators = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) allPeople - --- |Function to add a person to the database -insertPerson :: String -> String -> String -> IO () -insertPerson cf name surname = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runInsert $ insert (_persone fabLabDB) $ insertValues [ Person (pack cf) (pack name) (pack surname) False False False 0.0 ] - --- |Function to modify a person already in the database -modifyPerson :: String -> Bool -> Bool -> Bool -> IO () -modifyPerson cf partner cutter printer = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runUpdate $ update (_persone fabLabDB) - (\p -> mconcat [ _personSocio p <-. (val_ partner) - , _personOperatoreIntagliatrice p <-. (val_ cutter) - , _personOperatoreStampante p <-. (val_ printer) ]) - (\p -> _personCf p ==. (val_ (pack cf))) - --- materials queries --- |Function to add a person to the database -insertMaterialsClass :: String -> String -> IO () -insertMaterialsClass code name = do - conn <- connectPostgreSQL uri - runBeam putStrLn conn $ runInsert $ insert (_classi_di_materiali fabLabDB) $ insertValues [ MaterialsClass (pack code) (pack name) ] \ No newline at end of file diff --git a/src/Query.hs b/src/Query.hs new file mode 100644 index 0000000..ff68cde --- /dev/null +++ b/src/Query.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- |Module used for the queries in the database +module Query where + +import Data.ByteString (ByteString) +import Data.ByteString.UTF8 (fromString) +import Data.Int (Int) +import Data.Scientific +import Data.Text +import Data.Time.Calendar +import Database.Beam +import Database.Beam.Postgres +import Database.Beam.Query +import Schema + +-- constants +runBeam :: (String -> IO ()) -> Connection -> Pg a -> IO a +runBeam = runBeamPostgresDebug -- change for debug or production purposes + +allPeople :: Q Postgres FabLabDB s (PersonT (QExpr Postgres s)) +allPeople = all_ (_persone fabLabDB) + +allMaterialsClasses :: Q Postgres FabLabDB s (MaterialsClassT (QExpr Postgres s)) +allMaterialsClasses = all_ (_classi_di_materiali fabLabDB) + +allMaterials :: Q Postgres FabLabDB s (MaterialT (QExpr Postgres s)) +allMaterials = all_ (_materiali fabLabDB) + +allTypes :: Q Postgres FabLabDB s (TypeT (QExpr Postgres s)) +allTypes = all_ (_tipi fabLabDB) + +allPlastics :: Q Postgres FabLabDB s (PlasticT (QExpr Postgres s)) +allPlastics = all_ (_plastiche fabLabDB) + +-- |Given an uri, returns a connection to the database +connect :: String -> IO Connection +connect uri = connectPostgreSQL $ fromString uri + +-- people queries +-- |Select all people in the database +selectAllPeople :: Connection -> IO [Person] +selectAllPeople conn = + runBeam putStrLn conn + $ runSelectReturningList + $ select allPeople + +-- |Select all laser cutter operators in the database +selectLaserCutterOperators :: Connection -> IO [Person] +selectLaserCutterOperators conn = + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) allPeople + +-- |Select all 3D printer operators in the database +selectPrinterOperators :: Connection -> IO [Person] +selectPrinterOperators conn = + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) allPeople + +-- |Select all people with the given cf (should be 0 or 1) +selectPersonFromCF :: String -> (Connection -> IO [Person]) +selectPersonFromCF cf = + \conn -> + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _personCf p ==. (val_ (pack cf))) allPeople + +-- |Add a person to the database +insertPerson :: String -> String -> String -> (Connection -> IO ()) +insertPerson cf name surname = + \conn -> + runBeam putStrLn conn + $ runInsert + $ insert (_persone fabLabDB) + $ insertValues + [ Person + (pack cf) + (pack name) + (pack surname) + False + False + False + 0.0 + ] + +-- |Modify a person already in the database +modifyPerson :: String -> Bool -> Bool -> Bool -> (Connection -> IO ()) +modifyPerson cf partner cutter printer = + \conn -> + runBeam putStrLn conn + $ runUpdate + $ update (_persone fabLabDB) + ( \p -> + mconcat + [ _personSocio p <-. (val_ partner), + _personOperatoreIntagliatrice p <-. (val_ cutter), + _personOperatoreStampante p <-. (val_ printer) + ] + ) + (\p -> _personCf p ==. (val_ (pack cf))) + +-- materials queries +-- |Select all the materials classes with the given code (should be 1 or 0) +selectMaterialsClassFromCode :: String -> (Connection -> IO [MaterialsClass]) +selectMaterialsClassFromCode code = + \conn -> + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (pack code))) allMaterialsClasses + +-- |Select all materials with the given code (should be 1 or 0) +selectMaterialFromCode :: String -> (Connection -> IO [Material]) +selectMaterialFromCode code = + \conn -> + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (pack code))) allMaterials + +-- |Select all types of processing with the given code (should be 1 or 0) +selectTypeFromCode :: String -> (Connection -> IO [Type]) +selectTypeFromCode code = + \conn -> + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (pack code))) allTypes + +-- |Add a class of materials to the database +insertMaterialsClass :: String -> String -> (Connection -> IO ()) +insertMaterialsClass code name = + \conn -> + runBeam putStrLn conn + $ runInsert + $ insert (_classi_di_materiali fabLabDB) + $ insertValues + [ MaterialsClass + (pack code) + (pack name) + ] + +-- |Add a material to the database. The code is the id of the material inside the materials class. +insertMaterial :: String -> String -> String -> Double -> String -> (Connection -> IO ()) +insertMaterial code classCode name width descr = + \conn -> do + classes <- (selectMaterialsClassFromCode classCode) conn + let mClass = Prelude.head classes :: MaterialsClass + in runBeam putStrLn conn + $ runInsert + $ insert (_materiali fabLabDB) + $ insertValues + [ Material + (pk mClass) + (pack (classCode ++ code)) + (pack name) + width + (pack descr) + ] + +-- processings queries +-- |Add a type of processing to the database +insertType :: String -> String -> String -> (Connection -> IO ()) +insertType code name descr = + \conn -> + runBeam putStrLn conn + $ runInsert + $ insert (_tipi fabLabDB) + $ insertValues + [ Type + (pack code) + (pack name) + (pack descr) + ] + +-- |Add a new processing to the database +insertProcessing :: String -> String -> Int -> Int -> Int -> String -> (Connection -> IO ()) +insertProcessing typeCode materialCode maxPotency minPotency speed descr = + \conn -> do + types <- (selectTypeFromCode typeCode) conn + materials <- (selectMaterialFromCode materialCode) conn + let pType = Prelude.head types :: Type + material = Prelude.head materials :: Material + code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode + in runBeam putStrLn conn + $ runInsert + $ insert (_lavorazioni fabLabDB) + $ insertValues + [ Processing + (pk pType) + (pack code) + (pk material) + maxPotency + minPotency + speed + (pack descr) + ] + +-- plastics and filaments queries +-- |Select all the plastics with the given code (should be 1 or 0) +selectPlasticFromCode :: String -> (Connection -> IO [Plastic]) +selectPlasticFromCode code = + \conn -> + runBeam putStrLn conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (pack code))) allPlastics + +-- |Add a type of plastic to the database +insertPlastic :: String -> String -> String -> (Connection -> IO ()) +insertPlastic code name descr = undefined + +-- |Add a filament to the database. The code is the id of the filament inside the type of plastic +insertFilament :: String -> String -> String -> String -> (Connection -> IO ()) +insertFilament code plasticCode brand color = + \conn -> do + plastics <- (selectPlasticFromCode plasticCode) conn + let plastic = Prelude.head plastics :: Plastic + in runBeam putStrLn conn + $ runInsert + $ insert (_filamenti fabLabDB) + $ insertValues + [ Filament + (pack code) + (pk plastic) + (pack brand) + (pack color) + ] + +-- printers queries +-- |Add a printer to the database +insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) +insertPrinter code brand model descr = + \conn -> do + runBeam putStrLn conn + $ runInsert + $ insert (_stampanti fabLabDB) + $ insertValues [Printer (pack code) (pack brand) (pack model) (pack descr)] + +-- |Assign a printer to a print +assignPrinter :: String -> Int -> (Connection -> IO ()) +assignPrinter printer print = undefined + +-- prints queries +-- |Add a new print to the database +insertPrint :: String -> Day -> String -> (Connection -> IO ()) +insertPrint cf date descr = + \conn -> do + people <- (selectPersonFromCF cf) conn + let person = Prelude.head people :: Person + in runBeam putStrLn conn + $ runInsert + $ insert (_stampe fabLabDB) + $ insertExpressions + [ Print + { _printCodiceStampa = default_, + _printDataRichiesta = val_ date, + _printDataConsegna = val_ Nothing, + _printTempo = val_ Nothing, + _printCostoMateriali = val_ Nothing, + _printCostoTotale = val_ Nothing, + _printDescrizione = val_ (pack descr), + _printCfRichiedente = val_ (pk person), + _printCfIncaricato = nothing_, + _printCodiceStampante = nothing_ + } + ] + +-- |Assign a print to an operator +assignPrint :: Int -> String -> (Connection -> IO ()) +assignPrint code cf = undefined + +-- |Complete a print +completePrint :: Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completePrint date time total materials = undefined + +-- cuts queries +-- |Add a new cut to the database +insertCut :: String -> Day -> String -> (Connection -> IO ()) +insertCut cf date descr = + \conn -> do + people <- selectPersonFromCF cf conn + let person = Prelude.head people :: Person + in runBeam putStrLn conn + $ runInsert + $ insert (_intagli fabLabDB) + $ insertExpressions + [ Cut + { _cutCodiceIntaglio = default_, + _cutDataRichiesta = val_ date, + _cutDataConsegna = val_ Nothing, + _cutTempo = val_ Nothing, + _cutCostoMateriali = val_ Nothing, + _cutCostoTotale = val_ Nothing, + _cutDescrizione = val_ (pack descr), + _cutCfRichiedente = val_ (pk person), + _cutCfIncaricato = nothing_ + } + ] + +-- |Assign a cut to an operator +assignCut :: Int -> String -> (Connection -> IO ()) +assignCut code cf = undefined + +-- |Complete a cut +completeCut :: Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completeCut date time total materials = undefined diff --git a/src/Schema.hs b/src/Schema.hs new file mode 100644 index 0000000..3e2b9fc --- /dev/null +++ b/src/Schema.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- |Module used for defining the database schema +module Schema where + +import Data.ByteString (ByteString) +import Data.ByteString.UTF8 (fromString) +import Data.Int (Int) +import Data.Scientific +import Data.Text +import Data.Time.Calendar +import Database.Beam +import Database.Beam.Postgres +import Database.Beam.Schema.Tables + +-- costants +uri :: ByteString +uri = "postgres://postgres:14102002@localhost/FabLab" + +connection :: IO Connection +connection = connectPostgreSQL uri + +-- datatypes +-- |Data representing a person in the database +data PersonT f + = Person + { _personCf :: Columnar f Text, + _personNome :: Columnar f Text, + _personCognome :: Columnar f Text, + _personSocio :: Columnar f Bool, + _personOperatoreIntagliatrice :: Columnar f Bool, + _personOperatoreStampante :: Columnar f Bool, + _personSpesaTotale :: Columnar f Scientific + } + deriving (Beamable, Generic) + +instance Table PersonT where + + data PrimaryKey PersonT f = PersonId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = PersonId . _personCf + +type Person = PersonT Identity + +type PersonId = PrimaryKey PersonT Identity + +deriving instance Eq Person + +deriving instance Show Person + +deriving instance Eq PersonId + +deriving instance Show PersonId + +deriving instance Eq (PrimaryKey PersonT (Nullable Identity)) + +deriving instance Show (PrimaryKey PersonT (Nullable Identity)) + +-- |Data representing a print +data PrintT f + = Print + { _printCodiceStampa :: Columnar f Int, + _printDataRichiesta :: Columnar f Day, + _printDataConsegna :: Columnar f (Maybe Day), + _printTempo :: Columnar f (Maybe Double), + _printCostoMateriali :: Columnar f (Maybe Scientific), + _printCostoTotale :: Columnar f (Maybe Scientific), + _printDescrizione :: Columnar f Text, + _printCfRichiedente :: PrimaryKey PersonT f, + _printCfIncaricato :: PrimaryKey PersonT (Nullable f), + _printCodiceStampante :: PrimaryKey PrinterT (Nullable f) + } + deriving (Beamable, Generic) + +instance Table PrintT where + + data PrimaryKey PrintT f = PrintId (Columnar f Int) deriving (Beamable, Generic) + + primaryKey = PrintId . _printCodiceStampa + +type Print = PrintT Identity + +type PrintId = PrimaryKey PrintT Identity + +deriving instance Eq Print + +deriving instance Show Print + +deriving instance Eq PrintId + +deriving instance Show PrintId + +-- |Data representing a cut +data CutT f + = Cut + { _cutCodiceIntaglio :: Columnar f Int, + _cutDataRichiesta :: Columnar f Day, + _cutDataConsegna :: Columnar f (Maybe Day), + _cutTempo :: Columnar f (Maybe Double), + _cutCostoMateriali :: Columnar f (Maybe Scientific), + _cutCostoTotale :: Columnar f (Maybe Scientific), + _cutDescrizione :: Columnar f Text, + _cutCfRichiedente :: PrimaryKey PersonT f, + _cutCfIncaricato :: PrimaryKey PersonT (Nullable f) + } + deriving (Beamable, Generic) + +instance Table CutT where + + data PrimaryKey CutT f = CutId (Columnar f Int) deriving (Beamable, Generic) + + primaryKey = CutId . _cutCodiceIntaglio + +type Cut = CutT Identity + +type CutId = PrimaryKey CutT Identity + +deriving instance Eq Cut + +deriving instance Show Cut + +deriving instance Eq CutId + +deriving instance Show CutId + +-- |Data representing a printer +data PrinterT f + = Printer + { _printerCodiceStampante :: Columnar f Text, + _printerMarca :: Columnar f Text, + _printerModello :: Columnar f Text, + _printerDescrizione :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table PrinterT where + + data PrimaryKey PrinterT f = PrinterId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = PrinterId . _printerCodiceStampante + +type Printer = PrinterT Identity + +type PrinterId = PrimaryKey PrinterT Identity + +deriving instance Eq Printer + +deriving instance Show Printer + +deriving instance Eq PrinterId + +deriving instance Show PrinterId + +deriving instance Eq (PrimaryKey PrinterT (Nullable Identity)) + +deriving instance Show (PrimaryKey PrinterT (Nullable Identity)) + +-- |Data representing a type of plastic +data PlasticT f + = Plastic + { _plasticCodicePlastica :: Columnar f Text, + _plasticNome :: Columnar f Text, + _plasticDescrizione :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table PlasticT where + + data PrimaryKey PlasticT f = PlasticId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = PlasticId . _plasticCodicePlastica + +type Plastic = PlasticT Identity + +type PlasticId = PrimaryKey PlasticT Identity + +deriving instance Eq Plastic + +deriving instance Show Plastic + +deriving instance Eq PlasticId + +deriving instance Show PlasticId + +-- |Data representing a filament +data FilamentT f + = Filament + { _filamentCodiceFilamento :: Columnar f Text, + _filamentCodicePlastica :: PrimaryKey PlasticT f, + _filamentMarca :: Columnar f Text, + _filamentColore :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table FilamentT where + + data PrimaryKey FilamentT f = FilamentId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = FilamentId . _filamentCodiceFilamento + +type Filament = FilamentT Identity + +type FilamentId = PrimaryKey FilamentT Identity + +deriving instance Eq Filament + +deriving instance Show Filament + +deriving instance Eq FilamentId + +deriving instance Show FilamentId + +-- |Data representing a way of executing a cut +data ProcessingT f + = Processing + { _processingCodiceTipo :: PrimaryKey TypeT f, + _processingCodiceLavorazione :: Columnar f Text, + _processingCodiceMateriale :: PrimaryKey MaterialT f, + _processingPotenzaMassima :: Columnar f Int, + _processingPotenzaMinima :: Columnar f Int, + _processingVelocita :: Columnar f Int, + _processingDescrizione :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table ProcessingT where + + data PrimaryKey ProcessingT f = ProcessingId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = ProcessingId . _processingCodiceLavorazione + +type Processing = ProcessingT Identity + +type ProcessingId = PrimaryKey ProcessingT Identity + +deriving instance Eq Processing + +deriving instance Show Processing + +deriving instance Eq ProcessingId + +deriving instance Show ProcessingId + +-- |Data representing a type of processing +data TypeT f + = Type + { _typeCodiceTipo :: Columnar f Text, + _typeNome :: Columnar f Text, + _typeDescrizione :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table TypeT where + + data PrimaryKey TypeT f = TypeId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = TypeId . _typeCodiceTipo + +type Type = TypeT Identity + +type TypeId = PrimaryKey TypeT Identity + +deriving instance Eq Type + +deriving instance Show Type + +deriving instance Eq TypeId + +deriving instance Show TypeId + +-- |Data representing a material +data MaterialT f + = Material + { _materialCodiceClasse :: PrimaryKey MaterialsClassT f, + _materialCodiceMateriale :: Columnar f Text, + _materialNome :: Columnar f Text, + _materialSpessore :: Columnar f Double, + _materialDescrizione :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table MaterialT where + + data PrimaryKey MaterialT f = MaterialId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = MaterialId . _materialCodiceMateriale + +type Material = MaterialT Identity + +type MaterialId = PrimaryKey MaterialT Identity + +deriving instance Eq Material + +deriving instance Show Material + +deriving instance Eq MaterialId + +deriving instance Show MaterialId + +-- |Data representing a class of materials +data MaterialsClassT f + = MaterialsClass + { _materialsclassCodiceClasse :: Columnar f Text, + _materialsclassNome :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table MaterialsClassT where + + data PrimaryKey MaterialsClassT f = MaterialsClassId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = MaterialsClassId . _materialsclassCodiceClasse + +type MaterialsClass = MaterialsClassT Identity + +type MaterialsClassId = PrimaryKey MaterialsClassT Identity + +deriving instance Eq MaterialsClass + +deriving instance Show MaterialsClass + +deriving instance Eq MaterialsClassId + +deriving instance Show MaterialsClassId + +-- |Data representing a processing used in a cut +data CompositionT f + = Composition + { _compositionCodiceLavorazione :: PrimaryKey ProcessingT f, + _compositionCodiceIntaglio :: PrimaryKey CutT f + } + deriving (Beamable, Generic) + +instance Table CompositionT where + + data PrimaryKey CompositionT f = CompositionId (PrimaryKey ProcessingT f) (PrimaryKey CutT f) deriving (Beamable, Generic) + + primaryKey = CompositionId <$> _compositionCodiceLavorazione <*> _compositionCodiceIntaglio + +type Composition = CompositionT Identity + +type CompositionId = PrimaryKey CompositionT Identity + +deriving instance Eq Composition + +deriving instance Show Composition + +deriving instance Eq CompositionId + +deriving instance Show CompositionId + +-- |Data representing a filament used in a print +data UseT f + = Use + { _useCodiceFilamento :: PrimaryKey FilamentT f, + _useCodiceStampa :: PrimaryKey PrintT f + } + deriving (Beamable, Generic) + +instance Table UseT where + + data PrimaryKey UseT f = UseId (PrimaryKey FilamentT f) (PrimaryKey PrintT f) deriving (Beamable, Generic) + + primaryKey = UseId <$> _useCodiceFilamento <*> _useCodiceStampa + +type Use = UseT Identity + +type UseId = PrimaryKey UseT Identity + +deriving instance Eq Use + +deriving instance Show Use + +deriving instance Eq UseId + +deriving instance Show UseId + +-- |Data representing the database +data FabLabDB f + = FabLabDB + { _persone :: f (TableEntity PersonT), + _stampe :: f (TableEntity PrintT), + _intagli :: f (TableEntity CutT), + _stampanti :: f (TableEntity PrinterT), + _plastiche :: f (TableEntity PlasticT), + _filamenti :: f (TableEntity FilamentT), + _lavorazioni :: f (TableEntity ProcessingT), + _tipi :: f (TableEntity TypeT), + _materiali :: f (TableEntity MaterialT), + _classi_di_materiali :: f (TableEntity MaterialsClassT), + _composizioni :: f (TableEntity CompositionT), + _usi :: f (TableEntity UseT) + } + deriving (Database be, Generic) + +fabLabDB :: DatabaseSettings be FabLabDB +fabLabDB = + withDbModification defaultDbSettings + dbModification + { _stampe = + modifyTableFields + tableModification + { _printCfRichiedente = PersonId (fieldNamed "cf_richiedente"), + _printCfIncaricato = PersonId (fieldNamed "cf_incaricato"), + _printCodiceStampante = PrinterId (fieldNamed "codice_stampante") + }, + _intagli = + modifyTableFields + tableModification + { _cutCfRichiedente = PersonId (fieldNamed "cf_richiedente"), + _cutCfIncaricato = PersonId (fieldNamed "cf_incaricato") + } + } From 74007df4cb07615057751fe38b0fe60adc0d2c00 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 6 Sep 2019 11:31:55 +0200 Subject: [PATCH 05/73] Correct connection management, add queries --- src/Query.hs | 128 +++++++++++++++++++++++++++++++++++++++----------- src/Schema.hs | 5 +- 2 files changed, 101 insertions(+), 32 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index ff68cde..d09aaa4 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -26,8 +26,8 @@ import Database.Beam.Query import Schema -- constants -runBeam :: (String -> IO ()) -> Connection -> Pg a -> IO a -runBeam = runBeamPostgresDebug -- change for debug or production purposes +runBeam :: Connection -> Pg a -> IO a +runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production purposes allPeople :: Q Postgres FabLabDB s (PersonT (QExpr Postgres s)) allPeople = all_ (_persone fabLabDB) @@ -41,6 +41,9 @@ allMaterials = all_ (_materiali fabLabDB) allTypes :: Q Postgres FabLabDB s (TypeT (QExpr Postgres s)) allTypes = all_ (_tipi fabLabDB) +allPrinters :: Q Postgres FabLabDB s (PrinterT (QExpr Postgres s)) +allPrinters = all_ (_stampanti fabLabDB) + allPlastics :: Q Postgres FabLabDB s (PlasticT (QExpr Postgres s)) allPlastics = all_ (_plastiche fabLabDB) @@ -52,14 +55,14 @@ connect uri = connectPostgreSQL $ fromString uri -- |Select all people in the database selectAllPeople :: Connection -> IO [Person] selectAllPeople conn = - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select allPeople -- |Select all laser cutter operators in the database selectLaserCutterOperators :: Connection -> IO [Person] selectLaserCutterOperators conn = - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) allPeople @@ -67,7 +70,7 @@ selectLaserCutterOperators conn = -- |Select all 3D printer operators in the database selectPrinterOperators :: Connection -> IO [Person] selectPrinterOperators conn = - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) allPeople @@ -76,7 +79,7 @@ selectPrinterOperators conn = selectPersonFromCF :: String -> (Connection -> IO [Person]) selectPersonFromCF cf = \conn -> - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\p -> _personCf p ==. (val_ (pack cf))) allPeople @@ -85,7 +88,7 @@ selectPersonFromCF cf = insertPerson :: String -> String -> String -> (Connection -> IO ()) insertPerson cf name surname = \conn -> - runBeam putStrLn conn + runBeam conn $ runInsert $ insert (_persone fabLabDB) $ insertValues @@ -103,7 +106,7 @@ insertPerson cf name surname = modifyPerson :: String -> Bool -> Bool -> Bool -> (Connection -> IO ()) modifyPerson cf partner cutter printer = \conn -> - runBeam putStrLn conn + runBeam conn $ runUpdate $ update (_persone fabLabDB) ( \p -> @@ -120,7 +123,7 @@ modifyPerson cf partner cutter printer = selectMaterialsClassFromCode :: String -> (Connection -> IO [MaterialsClass]) selectMaterialsClassFromCode code = \conn -> - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (pack code))) allMaterialsClasses @@ -129,7 +132,7 @@ selectMaterialsClassFromCode code = selectMaterialFromCode :: String -> (Connection -> IO [Material]) selectMaterialFromCode code = \conn -> - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (pack code))) allMaterials @@ -138,7 +141,7 @@ selectMaterialFromCode code = selectTypeFromCode :: String -> (Connection -> IO [Type]) selectTypeFromCode code = \conn -> - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (pack code))) allTypes @@ -147,7 +150,7 @@ selectTypeFromCode code = insertMaterialsClass :: String -> String -> (Connection -> IO ()) insertMaterialsClass code name = \conn -> - runBeam putStrLn conn + runBeam conn $ runInsert $ insert (_classi_di_materiali fabLabDB) $ insertValues @@ -162,7 +165,7 @@ insertMaterial code classCode name width descr = \conn -> do classes <- (selectMaterialsClassFromCode classCode) conn let mClass = Prelude.head classes :: MaterialsClass - in runBeam putStrLn conn + in runBeam conn $ runInsert $ insert (_materiali fabLabDB) $ insertValues @@ -179,7 +182,7 @@ insertMaterial code classCode name width descr = insertType :: String -> String -> String -> (Connection -> IO ()) insertType code name descr = \conn -> - runBeam putStrLn conn + runBeam conn $ runInsert $ insert (_tipi fabLabDB) $ insertValues @@ -198,7 +201,7 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = let pType = Prelude.head types :: Type material = Prelude.head materials :: Material code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode - in runBeam putStrLn conn + in runBeam conn $ runInsert $ insert (_lavorazioni fabLabDB) $ insertValues @@ -217,14 +220,24 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = selectPlasticFromCode :: String -> (Connection -> IO [Plastic]) selectPlasticFromCode code = \conn -> - runBeam putStrLn conn + runBeam conn $ runSelectReturningList $ select $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (pack code))) allPlastics -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO ()) -insertPlastic code name descr = undefined +insertPlastic code name descr = + \conn -> + runBeam conn + $ runInsert + $ insert (_plastiche fabLabDB) + $ insertValues + [ Plastic + (pack code) + (pack name) + (pack descr) + ] -- |Add a filament to the database. The code is the id of the filament inside the type of plastic insertFilament :: String -> String -> String -> String -> (Connection -> IO ()) @@ -232,7 +245,7 @@ insertFilament code plasticCode brand color = \conn -> do plastics <- (selectPlasticFromCode plasticCode) conn let plastic = Prelude.head plastics :: Plastic - in runBeam putStrLn conn + in runBeam conn $ runInsert $ insert (_filamenti fabLabDB) $ insertValues @@ -244,18 +257,35 @@ insertFilament code plasticCode brand color = ] -- printers queries +-- |Select all the printers with the given code (should be 0 or 1) +selectPrinterFromCode :: String -> (Connection -> IO [Printer]) +selectPrinterFromCode code = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (pack code))) allPrinters + -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) insertPrinter code brand model descr = \conn -> do - runBeam putStrLn conn + runBeam conn $ runInsert $ insert (_stampanti fabLabDB) $ insertValues [Printer (pack code) (pack brand) (pack model) (pack descr)] -- |Assign a printer to a print assignPrinter :: String -> Int -> (Connection -> IO ()) -assignPrinter printer print = undefined +assignPrinter printerCode print = + \conn -> do + printers <- (selectPrinterFromCode printerCode) conn + let printer = Prelude.head printers + in runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) + (\s -> _printCodiceStampa s ==. (val_ print)) -- prints queries -- |Add a new print to the database @@ -264,7 +294,7 @@ insertPrint cf date descr = \conn -> do people <- (selectPersonFromCF cf) conn let person = Prelude.head people :: Person - in runBeam putStrLn conn + in runBeam conn $ runInsert $ insert (_stampe fabLabDB) $ insertExpressions @@ -284,11 +314,32 @@ insertPrint cf date descr = -- |Assign a print to an operator assignPrint :: Int -> String -> (Connection -> IO ()) -assignPrint code cf = undefined +assignPrint code cf = + \conn -> do + operators <- (selectPersonFromCF cf) conn + let operator = Prelude.head operators + in runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) + (\s -> _printCodiceStampa s ==. val_ code) -- |Complete a print -completePrint :: Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) -completePrint date time total materials = undefined +completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completePrint print date time total materials = + \conn -> + runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + ( \s -> + mconcat + [ _printDataConsegna s <-. val_ (Just date), + _printCostoMateriali s <-. val_ (Just materials), + _printCostoTotale s <-. val_ (Just total), + _printTempo s <-. val_ (Just time) + ] + ) + (\s -> _printCodiceStampa s ==. val_ print) -- cuts queries -- |Add a new cut to the database @@ -297,7 +348,7 @@ insertCut cf date descr = \conn -> do people <- selectPersonFromCF cf conn let person = Prelude.head people :: Person - in runBeam putStrLn conn + in runBeam conn $ runInsert $ insert (_intagli fabLabDB) $ insertExpressions @@ -316,8 +367,29 @@ insertCut cf date descr = -- |Assign a cut to an operator assignCut :: Int -> String -> (Connection -> IO ()) -assignCut code cf = undefined +assignCut code cf = + \conn -> do + operators <- (selectPersonFromCF cf) conn + let operator = Prelude.head operators + in runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) + (\c -> _cutCodiceIntaglio c ==. val_ code) -- |Complete a cut -completeCut :: Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) -completeCut date time total materials = undefined +completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completeCut code date time total materials = + \conn -> + runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + ( \c -> + mconcat + [ _cutDataConsegna c <-. val_ (Just date), + _cutCostoTotale c <-. val_ (Just total), + _cutCostoMateriali c <-. val_ (Just materials), + _cutTempo c <-. val_ (Just time) + ] + ) + (\c -> _cutCodiceIntaglio c ==. val_ code) diff --git a/src/Schema.hs b/src/Schema.hs index 3e2b9fc..79d249d 100644 --- a/src/Schema.hs +++ b/src/Schema.hs @@ -24,12 +24,9 @@ import Database.Beam.Postgres import Database.Beam.Schema.Tables -- costants -uri :: ByteString +uri :: String uri = "postgres://postgres:14102002@localhost/FabLab" -connection :: IO Connection -connection = connectPostgreSQL uri - -- datatypes -- |Data representing a person in the database data PersonT f From de79cb6e7c21dad1876e40539f3d1c3a6120cad4 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 6 Sep 2019 11:47:32 +0200 Subject: [PATCH 06/73] Converted to upper case all the codes --- src/Query.hs | 58 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 22 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index d09aaa4..5c5c038 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -51,6 +51,14 @@ allPlastics = all_ (_plastiche fabLabDB) connect :: String -> IO Connection connect uri = connectPostgreSQL $ fromString uri +-- |Prepares a code to be used as key +prepareCode :: String -> Text +prepareCode = toUpper . pack + +-- |Prepares a string to be used as a name in the database +prepareName :: String -> Text +prepareName = toTitle . pack + -- people queries -- |Select all people in the database selectAllPeople :: Connection -> IO [Person] @@ -93,9 +101,9 @@ insertPerson cf name surname = $ insert (_persone fabLabDB) $ insertValues [ Person - (pack cf) - (pack name) - (pack surname) + (prepareCode cf) + (prepareName name) + (prepareName surname) False False False @@ -116,7 +124,7 @@ modifyPerson cf partner cutter printer = _personOperatoreStampante p <-. (val_ printer) ] ) - (\p -> _personCf p ==. (val_ (pack cf))) + (\p -> _personCf p ==. (val_ (prepareCode cf))) -- materials queries -- |Select all the materials classes with the given code (should be 1 or 0) @@ -126,7 +134,7 @@ selectMaterialsClassFromCode code = runBeam conn $ runSelectReturningList $ select - $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (pack code))) allMaterialsClasses + $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) allMaterialsClasses -- |Select all materials with the given code (should be 1 or 0) selectMaterialFromCode :: String -> (Connection -> IO [Material]) @@ -135,7 +143,7 @@ selectMaterialFromCode code = runBeam conn $ runSelectReturningList $ select - $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (pack code))) allMaterials + $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) allMaterials -- |Select all types of processing with the given code (should be 1 or 0) selectTypeFromCode :: String -> (Connection -> IO [Type]) @@ -144,7 +152,7 @@ selectTypeFromCode code = runBeam conn $ runSelectReturningList $ select - $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (pack code))) allTypes + $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) allTypes -- |Add a class of materials to the database insertMaterialsClass :: String -> String -> (Connection -> IO ()) @@ -155,8 +163,8 @@ insertMaterialsClass code name = $ insert (_classi_di_materiali fabLabDB) $ insertValues [ MaterialsClass - (pack code) - (pack name) + (prepareCode code) + (prepareName name) ] -- |Add a material to the database. The code is the id of the material inside the materials class. @@ -171,8 +179,8 @@ insertMaterial code classCode name width descr = $ insertValues [ Material (pk mClass) - (pack (classCode ++ code)) - (pack name) + (prepareCode (classCode ++ code)) + (prepareName name) width (pack descr) ] @@ -187,8 +195,8 @@ insertType code name descr = $ insert (_tipi fabLabDB) $ insertValues [ Type - (pack code) - (pack name) + (prepareCode code) + (prepareName name) (pack descr) ] @@ -207,7 +215,7 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = $ insertValues [ Processing (pk pType) - (pack code) + (prepareCode code) (pk material) maxPotency minPotency @@ -223,7 +231,7 @@ selectPlasticFromCode code = runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (pack code))) allPlastics + $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) allPlastics -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO ()) @@ -234,8 +242,8 @@ insertPlastic code name descr = $ insert (_plastiche fabLabDB) $ insertValues [ Plastic - (pack code) - (pack name) + (prepareCode code) + (prepareName name) (pack descr) ] @@ -250,10 +258,10 @@ insertFilament code plasticCode brand color = $ insert (_filamenti fabLabDB) $ insertValues [ Filament - (pack code) + (prepareCode code) (pk plastic) - (pack brand) - (pack color) + (prepareName brand) + (prepareName color) ] -- printers queries @@ -264,7 +272,7 @@ selectPrinterFromCode code = runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (pack code))) allPrinters + $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) allPrinters -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) @@ -273,7 +281,13 @@ insertPrinter code brand model descr = runBeam conn $ runInsert $ insert (_stampanti fabLabDB) - $ insertValues [Printer (pack code) (pack brand) (pack model) (pack descr)] + $ insertValues + [ Printer + (prepareCode code) + (prepareName brand) + (prepareName model) + (pack descr) + ] -- |Assign a printer to a print assignPrinter :: String -> Int -> (Connection -> IO ()) From 5233e75a01928b1cd67634ad056a8875ebb0f61f Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 6 Sep 2019 11:50:38 +0200 Subject: [PATCH 07/73] Add createUri function --- src/Schema.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Schema.hs b/src/Schema.hs index 79d249d..8ca070a 100644 --- a/src/Schema.hs +++ b/src/Schema.hs @@ -24,8 +24,8 @@ import Database.Beam.Postgres import Database.Beam.Schema.Tables -- costants -uri :: String -uri = "postgres://postgres:14102002@localhost/FabLab" +createUri :: String -> String -> String +createUri user pswd = "postgres://" ++ user ++ ":" ++ pswd ++ "@localhost/FabLab" -- datatypes -- |Data representing a person in the database From 72bc3fc09cf6d3fb548e000461e45806091bfa76 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 8 Sep 2019 14:43:20 +0200 Subject: [PATCH 08/73] Move createUri from Schema.hs to Query.hs, add queries --- src/Query.hs | 241 ++++++++++++++++++++++++++++++++++++++++---------- src/Schema.hs | 4 - 2 files changed, 194 insertions(+), 51 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 5c5c038..3bbe16b 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -21,36 +21,41 @@ import Data.Scientific import Data.Text import Data.Time.Calendar import Database.Beam +import Database.Beam.Backend.SQL (BeamSqlBackend) import Database.Beam.Postgres import Database.Beam.Query import Schema --- constants -runBeam :: Connection -> Pg a -> IO a -runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production purposes - -allPeople :: Q Postgres FabLabDB s (PersonT (QExpr Postgres s)) -allPeople = all_ (_persone fabLabDB) - -allMaterialsClasses :: Q Postgres FabLabDB s (MaterialsClassT (QExpr Postgres s)) -allMaterialsClasses = all_ (_classi_di_materiali fabLabDB) - -allMaterials :: Q Postgres FabLabDB s (MaterialT (QExpr Postgres s)) -allMaterials = all_ (_materiali fabLabDB) - -allTypes :: Q Postgres FabLabDB s (TypeT (QExpr Postgres s)) -allTypes = all_ (_tipi fabLabDB) - -allPrinters :: Q Postgres FabLabDB s (PrinterT (QExpr Postgres s)) -allPrinters = all_ (_stampanti fabLabDB) - -allPlastics :: Q Postgres FabLabDB s (PlasticT (QExpr Postgres s)) -allPlastics = all_ (_plastiche fabLabDB) +-- constants and general functions +-- |Creates an uri for connecting to the database with the given username and password +createUri :: String -> String -> String +createUri user pswd = "postgres://" ++ user ++ ":" ++ pswd ++ "@localhost/FabLab" -- |Given an uri, returns a connection to the database connect :: String -> IO Connection connect uri = connectPostgreSQL $ fromString uri +runBeam :: Connection -> Pg a -> IO a +runBeam = runBeamPostgresDebug putStrLn -- change for debug or production purposes + +allElementsOfTable + :: (Table t, BeamSqlBackend be) + => ( DatabaseSettings be FabLabDB + -> DatabaseEntity be FabLabDB (TableEntity t) + ) + -> Q be FabLabDB s (t (QExpr be s)) +allElementsOfTable table = all_ (table fabLabDB) + +-- |A generic select with filters +-- | table :: Table t => ( DatabaseSettings be FabLabDB -> DatabaseEntity be FabLabDB (TableEntity t)) +-- | filter :: Table t => (t (QExpr be s)) -> QExpr be s Bool +selectWithFilters table filter = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ filter $ allElementsOfTable table + -- |Prepares a code to be used as key prepareCode :: String -> Text prepareCode = toUpper . pack @@ -65,32 +70,32 @@ selectAllPeople :: Connection -> IO [Person] selectAllPeople conn = runBeam conn $ runSelectReturningList - $ select allPeople + $ select $ allElementsOfTable _persone -- |Select all laser cutter operators in the database -selectLaserCutterOperators :: Connection -> IO [Person] -selectLaserCutterOperators conn = +selectAllLaserCutterOperators :: Connection -> IO [Person] +selectAllLaserCutterOperators conn = runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) allPeople + $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) $ allElementsOfTable _persone -- |Select all 3D printer operators in the database -selectPrinterOperators :: Connection -> IO [Person] -selectPrinterOperators conn = +selectAllPrinterOperators :: Connection -> IO [Person] +selectAllPrinterOperators conn = runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) allPeople + $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) $ allElementsOfTable _persone --- |Select all people with the given cf (should be 0 or 1) +-- |Select all people with the given cf (should be 0 or 1) in the database selectPersonFromCF :: String -> (Connection -> IO [Person]) selectPersonFromCF cf = \conn -> runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _personCf p ==. (val_ (pack cf))) allPeople + $ filter_ (\p -> _personCf p ==. (val_ (pack cf))) $ allElementsOfTable _persone -- |Add a person to the database insertPerson :: String -> String -> String -> (Connection -> IO ()) @@ -127,34 +132,52 @@ modifyPerson cf partner cutter printer = (\p -> _personCf p ==. (val_ (prepareCode cf))) -- materials queries --- |Select all the materials classes with the given code (should be 1 or 0) +-- |Select all materials in the database +selectAllMaterials :: Connection -> IO [Material] +selectAllMaterials = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _materiali + +-- |Select all classes of materials in the database +selectAllMaterialsClasses :: Connection -> IO [MaterialsClass] +selectAllMaterialsClasses = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _classi_di_materiali + +-- |Select all the materials classes with the given code (should be 1 or 0) in the database selectMaterialsClassFromCode :: String -> (Connection -> IO [MaterialsClass]) selectMaterialsClassFromCode code = \conn -> runBeam conn $ runSelectReturningList $ select - $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) allMaterialsClasses + $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) $ allElementsOfTable _classi_di_materiali --- |Select all materials with the given code (should be 1 or 0) +-- |Select all materials with the given code (should be 1 or 0) in the database selectMaterialFromCode :: String -> (Connection -> IO [Material]) selectMaterialFromCode code = \conn -> runBeam conn $ runSelectReturningList $ select - $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) allMaterials + $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) $ allElementsOfTable _materiali --- |Select all types of processing with the given code (should be 1 or 0) -selectTypeFromCode :: String -> (Connection -> IO [Type]) -selectTypeFromCode code = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) allTypes +-- |Select all materials of a given class in the database +selectMaterialsByClass :: String -> (Connection -> IO [Material]) +selectMaterialsByClass classCode = + \conn -> do + classes <- (selectMaterialsClassFromCode classCode) conn + let mClass = Prelude.head classes :: MaterialsClass + in runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) $ allElementsOfTable _materiali --- |Add a class of materials to the database +-- |Add a class of materials to the database in the database insertMaterialsClass :: String -> String -> (Connection -> IO ()) insertMaterialsClass code name = \conn -> @@ -186,6 +209,43 @@ insertMaterial code classCode name width descr = ] -- processings queries +-- |Select all processings in the database +selectAllProcessings :: Connection -> IO [Processing] +selectAllProcessings = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _lavorazioni + +-- |Select all types of processing in the database +selectAllTypes :: Connection -> IO [Type] +selectAllTypes = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _tipi + +-- |Select all types of processing with the given code (should be 1 or 0) in the database +selectTypeFromCode :: String -> (Connection -> IO [Type]) +selectTypeFromCode code = + \conn -> + let + in runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) $ allElementsOfTable _tipi + +-- |Select all processings on a given material in the database +selectProcessingsByMaterials :: String -> (Connection -> IO [Processing]) +selectProcessingsByMaterials mCode = + \conn -> do + materials <- (selectMaterialFromCode mCode) conn + let material = Prelude.head materials :: Material + in runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) $ allElementsOfTable _lavorazioni + -- |Add a type of processing to the database insertType :: String -> String -> String -> (Connection -> IO ()) insertType code name descr = @@ -224,14 +284,41 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = ] -- plastics and filaments queries --- |Select all the plastics with the given code (should be 1 or 0) +-- |Select all filaments in the database +selectAllFilaments :: Connection -> IO [Filament] +selectAllFilaments = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _filamenti + +-- |Select all plastics in the database +selectAllPlastics :: Connection -> IO [Plastic] +selectAllPlastics = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _plastiche + +-- |Select all the plastics with the given code (should be 1 or 0) in the database selectPlasticFromCode :: String -> (Connection -> IO [Plastic]) selectPlasticFromCode code = \conn -> runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) allPlastics + $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) $ allElementsOfTable _plastiche + +-- |Select the filaments made of a given plastic in the database +selectFilamentsByPlastic :: String -> (Connection -> IO [Filament]) +selectFilamentsByPlastic pCode = + \conn -> do + plastics <- (selectPlasticFromCode pCode) conn + let plastic = Prelude.head plastics :: Plastic + in runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) $ allElementsOfTable _filamenti -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO ()) @@ -265,14 +352,22 @@ insertFilament code plasticCode brand color = ] -- printers queries --- |Select all the printers with the given code (should be 0 or 1) +-- |Select all printers in the database +selectAllPrinters :: Connection -> IO [Printer] +selectAllPrinters = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _stampanti + +-- |Select all the printers with the given code (should be 0 or 1) in the database selectPrinterFromCode :: String -> (Connection -> IO [Printer]) selectPrinterFromCode code = \conn -> runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) allPrinters + $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) $ allElementsOfTable _stampanti -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) @@ -302,6 +397,32 @@ assignPrinter printerCode print = (\s -> _printCodiceStampa s ==. (val_ print)) -- prints queries +-- |Select all prints in the database +selectAllPrints :: Connection -> IO [Print] +selectAllPrints = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _stampe + +-- |Select all the print that aren't completed in the database +selectAllIncompletePrints :: Connection -> IO [Print] +selectAllIncompletePrints = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _printDataConsegna p ==. val_ Nothing) $ allElementsOfTable _stampe + +-- |Select all the completed prints in the database +selectAllCompletePrints :: Connection -> IO [Print] +selectAllCompletePrints = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _printDataConsegna p /=. val_ Nothing) $ allElementsOfTable _stampe + -- |Add a new print to the database insertPrint :: String -> Day -> String -> (Connection -> IO ()) insertPrint cf date descr = @@ -356,6 +477,32 @@ completePrint print date time total materials = (\s -> _printCodiceStampa s ==. val_ print) -- cuts queries +-- |Select all cuts in the database +selectAllCuts :: Connection -> IO [Cut] +selectAllCuts = + \conn -> + runBeam conn + $ runSelectReturningList + $ select $ allElementsOfTable _intagli + +-- |Select all the print that aren't completed in the database +selectAllIncompleteCuts :: Connection -> IO [Cut] +selectAllIncompleteCuts = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\c -> _cutDataConsegna c ==. val_ Nothing) $ allElementsOfTable _intagli + +-- |Select all the completed prints in the database +selectAllCompleteCuts :: Connection -> IO [Cut] +selectAllCompleteCuts = + \conn -> + runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\c -> _cutDataConsegna c /=. val_ Nothing) $ allElementsOfTable _intagli + -- |Add a new cut to the database insertCut :: String -> Day -> String -> (Connection -> IO ()) insertCut cf date descr = diff --git a/src/Schema.hs b/src/Schema.hs index 8ca070a..8fb866f 100644 --- a/src/Schema.hs +++ b/src/Schema.hs @@ -23,10 +23,6 @@ import Database.Beam import Database.Beam.Postgres import Database.Beam.Schema.Tables --- costants -createUri :: String -> String -> String -createUri user pswd = "postgres://" ++ user ++ ":" ++ pswd ++ "@localhost/FabLab" - -- datatypes -- |Data representing a person in the database data PersonT f From 274280864b8c5962b9f19b238f251f11857d2fbc Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 8 Sep 2019 15:36:39 +0200 Subject: [PATCH 09/73] Fix tables fields names --- src/Schema.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/Schema.hs b/src/Schema.hs index 8fb866f..c1b9f1b 100644 --- a/src/Schema.hs +++ b/src/Schema.hs @@ -412,5 +412,33 @@ fabLabDB = tableModification { _cutCfRichiedente = PersonId (fieldNamed "cf_richiedente"), _cutCfIncaricato = PersonId (fieldNamed "cf_incaricato") + }, + _materiali = + modifyTableFields + tableModification + { _materialCodiceClasse = MaterialsClassId (fieldNamed "codice_classe") + }, + _filamenti = + modifyTableFields + tableModification + { _filamentCodicePlastica = PlasticId (fieldNamed "codice_plastica") + }, + _lavorazioni = + modifyTableFields + tableModification + { _processingCodiceTipo = TypeId (fieldNamed "codice_tipo"), + _processingCodiceMateriale = MaterialId (fieldNamed "codice_materiale") + }, + _composizioni = + modifyTableFields + tableModification + { _compositionCodiceIntaglio = CutId (fieldNamed "codice_intaglio"), + _compositionCodiceLavorazione = ProcessingId (fieldNamed "codice_lavorazione") + }, + _usi = + modifyTableFields + tableModification + { _useCodiceFilamento = FilamentId (fieldNamed "codice_filamento"), + _useCodiceStampa = PrintId (fieldNamed "codice_stampa") } } From 1731cbc47d0365a37d82ed677d1272d8e705db72 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 8 Sep 2019 15:37:12 +0200 Subject: [PATCH 10/73] Refactor select queries, add queries --- src/Query.hs | 213 +++++++++++++++++++++++---------------------------- 1 file changed, 94 insertions(+), 119 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 3bbe16b..f7d455b 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -49,12 +49,14 @@ allElementsOfTable table = all_ (table fabLabDB) -- |A generic select with filters -- | table :: Table t => ( DatabaseSettings be FabLabDB -> DatabaseEntity be FabLabDB (TableEntity t)) -- | filter :: Table t => (t (QExpr be s)) -> QExpr be s Bool -selectWithFilters table filter = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ filter $ allElementsOfTable table +genericSelect table filter = + let pool = case filter of + Nothing -> allElementsOfTable table + Just f -> filter_ f $ allElementsOfTable table + in \conn -> + runBeam conn + $ runSelectReturningList + $ select pool -- |Prepares a code to be used as key prepareCode :: String -> Text @@ -67,35 +69,22 @@ prepareName = toTitle . pack -- people queries -- |Select all people in the database selectAllPeople :: Connection -> IO [Person] -selectAllPeople conn = - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _persone +selectAllPeople = genericSelect _persone Nothing -- |Select all laser cutter operators in the database selectAllLaserCutterOperators :: Connection -> IO [Person] -selectAllLaserCutterOperators conn = - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) $ allElementsOfTable _persone +selectAllLaserCutterOperators = + genericSelect _persone $ Just (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) -- |Select all 3D printer operators in the database selectAllPrinterOperators :: Connection -> IO [Person] -selectAllPrinterOperators conn = - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _personOperatoreStampante p ==. (val_ True)) $ allElementsOfTable _persone +selectAllPrinterOperators = + genericSelect _persone $ Just (\p -> _personOperatoreStampante p ==. (val_ True)) -- |Select all people with the given cf (should be 0 or 1) in the database selectPersonFromCF :: String -> (Connection -> IO [Person]) selectPersonFromCF cf = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _personCf p ==. (val_ (pack cf))) $ allElementsOfTable _persone + genericSelect _persone $ Just (\p -> _personCf p ==. (val_ (pack cf))) -- |Add a person to the database insertPerson :: String -> String -> String -> (Connection -> IO ()) @@ -134,37 +123,21 @@ modifyPerson cf partner cutter printer = -- materials queries -- |Select all materials in the database selectAllMaterials :: Connection -> IO [Material] -selectAllMaterials = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _materiali +selectAllMaterials = genericSelect _materiali Nothing -- |Select all classes of materials in the database selectAllMaterialsClasses :: Connection -> IO [MaterialsClass] -selectAllMaterialsClasses = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _classi_di_materiali +selectAllMaterialsClasses = genericSelect _classi_di_materiali Nothing -- |Select all the materials classes with the given code (should be 1 or 0) in the database selectMaterialsClassFromCode :: String -> (Connection -> IO [MaterialsClass]) selectMaterialsClassFromCode code = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) $ allElementsOfTable _classi_di_materiali + genericSelect _classi_di_materiali $ Just (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) -- |Select all materials with the given code (should be 1 or 0) in the database selectMaterialFromCode :: String -> (Connection -> IO [Material]) selectMaterialFromCode code = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) $ allElementsOfTable _materiali + genericSelect _materiali $ Just (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) -- |Select all materials of a given class in the database selectMaterialsByClass :: String -> (Connection -> IO [Material]) @@ -175,7 +148,8 @@ selectMaterialsByClass classCode = in runBeam conn $ runSelectReturningList $ select - $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) $ allElementsOfTable _materiali + $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) + $ allElementsOfTable _materiali -- |Add a class of materials to the database in the database insertMaterialsClass :: String -> String -> (Connection -> IO ()) @@ -209,31 +183,23 @@ insertMaterial code classCode name width descr = ] -- processings queries +-- |Select the processing with the given code in the database +selectProcessingFromCode :: String -> (Connection -> IO [Processing]) +selectProcessingFromCode pCode = + genericSelect _lavorazioni $ Just (\p -> _processingCodiceLavorazione p ==. val_ (prepareCode pCode)) + -- |Select all processings in the database selectAllProcessings :: Connection -> IO [Processing] -selectAllProcessings = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _lavorazioni +selectAllProcessings = genericSelect _lavorazioni Nothing -- |Select all types of processing in the database selectAllTypes :: Connection -> IO [Type] -selectAllTypes = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _tipi +selectAllTypes = genericSelect _tipi Nothing -- |Select all types of processing with the given code (should be 1 or 0) in the database selectTypeFromCode :: String -> (Connection -> IO [Type]) selectTypeFromCode code = - \conn -> - let - in runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) $ allElementsOfTable _tipi + genericSelect _tipi $ Just (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) -- |Select all processings on a given material in the database selectProcessingsByMaterials :: String -> (Connection -> IO [Processing]) @@ -244,7 +210,8 @@ selectProcessingsByMaterials mCode = in runBeam conn $ runSelectReturningList $ select - $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) $ allElementsOfTable _lavorazioni + $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) + $ allElementsOfTable _lavorazioni -- |Add a type of processing to the database insertType :: String -> String -> String -> (Connection -> IO ()) @@ -286,28 +253,21 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = -- plastics and filaments queries -- |Select all filaments in the database selectAllFilaments :: Connection -> IO [Filament] -selectAllFilaments = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _filamenti +selectAllFilaments = genericSelect _filamenti Nothing -- |Select all plastics in the database selectAllPlastics :: Connection -> IO [Plastic] -selectAllPlastics = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _plastiche +selectAllPlastics = genericSelect _plastiche Nothing -- |Select all the plastics with the given code (should be 1 or 0) in the database selectPlasticFromCode :: String -> (Connection -> IO [Plastic]) selectPlasticFromCode code = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) $ allElementsOfTable _plastiche + genericSelect _plastiche $ Just (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) + +-- |Select all the filaments with the given code (should be 1 or 0) in the database +selectFilamentFromCode :: String -> (Connection -> IO [Filament]) +selectFilamentFromCode code = + genericSelect _filamenti $ Just (\f -> _filamentCodiceFilamento f ==. (val_ (prepareCode code))) -- |Select the filaments made of a given plastic in the database selectFilamentsByPlastic :: String -> (Connection -> IO [Filament]) @@ -318,7 +278,8 @@ selectFilamentsByPlastic pCode = in runBeam conn $ runSelectReturningList $ select - $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) $ allElementsOfTable _filamenti + $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) + $ allElementsOfTable _filamenti -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO ()) @@ -354,20 +315,12 @@ insertFilament code plasticCode brand color = -- printers queries -- |Select all printers in the database selectAllPrinters :: Connection -> IO [Printer] -selectAllPrinters = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _stampanti +selectAllPrinters = genericSelect _stampanti Nothing -- |Select all the printers with the given code (should be 0 or 1) in the database selectPrinterFromCode :: String -> (Connection -> IO [Printer]) selectPrinterFromCode code = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) $ allElementsOfTable _stampanti + genericSelect _stampanti $ Just (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) @@ -397,31 +350,24 @@ assignPrinter printerCode print = (\s -> _printCodiceStampa s ==. (val_ print)) -- prints queries +-- |Select the print with the given code in the database (should be 0 or 1) +selectPrintFromCode :: Int -> (Connection -> IO [Print]) +selectPrintFromCode pCode = + genericSelect _stampe $ Just (\p -> _printCodiceStampa p ==. val_ pCode) + -- |Select all prints in the database selectAllPrints :: Connection -> IO [Print] -selectAllPrints = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _stampe +selectAllPrints = genericSelect _stampe Nothing -- |Select all the print that aren't completed in the database selectAllIncompletePrints :: Connection -> IO [Print] selectAllIncompletePrints = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _printDataConsegna p ==. val_ Nothing) $ allElementsOfTable _stampe + genericSelect _stampe $ Just (\p -> _printDataConsegna p ==. val_ Nothing) -- |Select all the completed prints in the database selectAllCompletePrints :: Connection -> IO [Print] selectAllCompletePrints = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _printDataConsegna p /=. val_ Nothing) $ allElementsOfTable _stampe + genericSelect _stampe $ Just (\p -> _printDataConsegna p /=. val_ Nothing) -- |Add a new print to the database insertPrint :: String -> Day -> String -> (Connection -> IO ()) @@ -459,6 +405,24 @@ assignPrint code cf = (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) (\s -> _printCodiceStampa s ==. val_ code) +-- |Assign a filament to a print in the database +assignFilament :: Int -> String -> (Connection -> IO ()) +assignFilament pCode fCode = + \conn -> do + filaments <- (selectFilamentFromCode fCode) conn + prints <- (selectPrintFromCode pCode) conn + let filament = Prelude.head filaments + print = Prelude.head prints + in runBeam conn + $ runInsert + $ insert (_usi fabLabDB) + $ insertExpressions + [ Use + { _useCodiceFilamento = val_ (pk filament), + _useCodiceStampa = val_ (pk print) + } + ] + -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) completePrint print date time total materials = @@ -477,31 +441,24 @@ completePrint print date time total materials = (\s -> _printCodiceStampa s ==. val_ print) -- cuts queries +-- |Select the cut with the given code in the database (should be 0 or 1) +selectCutFromCode :: Int -> (Connection -> IO [Cut]) +selectCutFromCode cCode = + genericSelect _intagli $ Just (\c -> _cutCodiceIntaglio c ==. val_ cCode) + -- |Select all cuts in the database selectAllCuts :: Connection -> IO [Cut] -selectAllCuts = - \conn -> - runBeam conn - $ runSelectReturningList - $ select $ allElementsOfTable _intagli +selectAllCuts = genericSelect _intagli Nothing -- |Select all the print that aren't completed in the database selectAllIncompleteCuts :: Connection -> IO [Cut] selectAllIncompleteCuts = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\c -> _cutDataConsegna c ==. val_ Nothing) $ allElementsOfTable _intagli + genericSelect _intagli $ Just (\c -> _cutDataConsegna c ==. val_ Nothing) -- |Select all the completed prints in the database selectAllCompleteCuts :: Connection -> IO [Cut] selectAllCompleteCuts = - \conn -> - runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\c -> _cutDataConsegna c /=. val_ Nothing) $ allElementsOfTable _intagli + genericSelect _intagli $ Just (\c -> _cutDataConsegna c /=. val_ Nothing) -- |Add a new cut to the database insertCut :: String -> Day -> String -> (Connection -> IO ()) @@ -538,6 +495,24 @@ assignCut code cf = (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) (\c -> _cutCodiceIntaglio c ==. val_ code) +-- |Assign a processing to a print +assignProcessing :: Int -> String -> (Connection -> IO ()) +assignProcessing cCode pCode = + \conn -> do + processings <- (selectProcessingFromCode pCode) conn + cuts <- (selectCutFromCode cCode) conn + let processing = Prelude.head processings + cut = Prelude.head cuts + in runBeam conn + $ runInsert + $ insert (_composizioni fabLabDB) + $ insertExpressions + [ Composition + { _compositionCodiceLavorazione = val_ (pk processing), + _compositionCodiceIntaglio = val_ (pk cut) + } + ] + -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) completeCut code date time total materials = From 0f1a1c0c5d847ecffa5b7985899a0e8448ccde2b Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 8 Sep 2019 16:05:25 +0200 Subject: [PATCH 11/73] Made code more readable --- src/Query.hs | 50 +++++++++++++++++++++++++++++--------------------- src/Schema.hs | 4 ---- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index f7d455b..0cb6b5b 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -14,7 +14,6 @@ -- |Module used for the queries in the database module Query where -import Data.ByteString (ByteString) import Data.ByteString.UTF8 (fromString) import Data.Int (Int) import Data.Scientific @@ -23,7 +22,6 @@ import Data.Time.Calendar import Database.Beam import Database.Beam.Backend.SQL (BeamSqlBackend) import Database.Beam.Postgres -import Database.Beam.Query import Schema -- constants and general functions @@ -47,10 +45,20 @@ allElementsOfTable allElementsOfTable table = all_ (table fabLabDB) -- |A generic select with filters --- | table :: Table t => ( DatabaseSettings be FabLabDB -> DatabaseEntity be FabLabDB (TableEntity t)) --- | filter :: Table t => (t (QExpr be s)) -> QExpr be s Bool -genericSelect table filter = - let pool = case filter of +{-genericSelect :: (Table t, Generic (t Identity), + Generic (t Database.Beam.Backend.Types.Exposed), + Database.Beam.Backend.SQL.Row.GFromBackendRow + Postgres + (GHC.Generics.Rep (t Database.Beam.Backend.Types.Exposed)) + (GHC.Generics.Rep (t Identity))) => + (DatabaseSettings Postgres FabLabDB + -> DatabaseEntity Postgres FabLabDB (TableEntity t)) + -> Maybe + (t (QExpr Postgres QBaseScope) -> QExpr Postgres QBaseScope Bool) + -> Connection + -> IO [t Identity]-} +genericSelect table maybeFilter = + let pool = case maybeFilter of Nothing -> allElementsOfTable table Just f -> filter_ f $ allElementsOfTable table in \conn -> @@ -339,7 +347,7 @@ insertPrinter code brand model descr = -- |Assign a printer to a print assignPrinter :: String -> Int -> (Connection -> IO ()) -assignPrinter printerCode print = +assignPrinter printerCode printCode = \conn -> do printers <- (selectPrinterFromCode printerCode) conn let printer = Prelude.head printers @@ -347,7 +355,7 @@ assignPrinter printerCode print = $ runUpdate $ update (_stampe fabLabDB) (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) - (\s -> _printCodiceStampa s ==. (val_ print)) + (\s -> _printCodiceStampa s ==. (val_ printCode)) -- prints queries -- |Select the print with the given code in the database (should be 0 or 1) @@ -371,7 +379,7 @@ selectAllCompletePrints = -- |Add a new print to the database insertPrint :: String -> Day -> String -> (Connection -> IO ()) -insertPrint cf date descr = +insertPrint cf insertDate descr = \conn -> do people <- (selectPersonFromCF cf) conn let person = Prelude.head people :: Person @@ -381,7 +389,7 @@ insertPrint cf date descr = $ insertExpressions [ Print { _printCodiceStampa = default_, - _printDataRichiesta = val_ date, + _printDataRichiesta = val_ insertDate, _printDataConsegna = val_ Nothing, _printTempo = val_ Nothing, _printCostoMateriali = val_ Nothing, @@ -412,33 +420,33 @@ assignFilament pCode fCode = filaments <- (selectFilamentFromCode fCode) conn prints <- (selectPrintFromCode pCode) conn let filament = Prelude.head filaments - print = Prelude.head prints + selectedPrint = Prelude.head prints in runBeam conn $ runInsert $ insert (_usi fabLabDB) $ insertExpressions [ Use { _useCodiceFilamento = val_ (pk filament), - _useCodiceStampa = val_ (pk print) + _useCodiceStampa = val_ (pk selectedPrint) } ] -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) -completePrint print date time total materials = +completePrint pCode deliveryDate workTime total materials = \conn -> runBeam conn $ runUpdate $ update (_stampe fabLabDB) ( \s -> mconcat - [ _printDataConsegna s <-. val_ (Just date), + [ _printDataConsegna s <-. val_ (Just deliveryDate), _printCostoMateriali s <-. val_ (Just materials), _printCostoTotale s <-. val_ (Just total), - _printTempo s <-. val_ (Just time) + _printTempo s <-. val_ (Just workTime) ] ) - (\s -> _printCodiceStampa s ==. val_ print) + (\s -> _printCodiceStampa s ==. val_ pCode) -- cuts queries -- |Select the cut with the given code in the database (should be 0 or 1) @@ -462,7 +470,7 @@ selectAllCompleteCuts = -- |Add a new cut to the database insertCut :: String -> Day -> String -> (Connection -> IO ()) -insertCut cf date descr = +insertCut cf insertDate descr = \conn -> do people <- selectPersonFromCF cf conn let person = Prelude.head people :: Person @@ -472,7 +480,7 @@ insertCut cf date descr = $ insertExpressions [ Cut { _cutCodiceIntaglio = default_, - _cutDataRichiesta = val_ date, + _cutDataRichiesta = val_ insertDate, _cutDataConsegna = val_ Nothing, _cutTempo = val_ Nothing, _cutCostoMateriali = val_ Nothing, @@ -515,17 +523,17 @@ assignProcessing cCode pCode = -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) -completeCut code date time total materials = +completeCut code deliveryDate workTime total materials = \conn -> runBeam conn $ runUpdate $ update (_intagli fabLabDB) ( \c -> mconcat - [ _cutDataConsegna c <-. val_ (Just date), + [ _cutDataConsegna c <-. val_ (Just deliveryDate), _cutCostoTotale c <-. val_ (Just total), _cutCostoMateriali c <-. val_ (Just materials), - _cutTempo c <-. val_ (Just time) + _cutTempo c <-. val_ (Just workTime) ] ) (\c -> _cutCodiceIntaglio c ==. val_ code) diff --git a/src/Schema.hs b/src/Schema.hs index c1b9f1b..222288d 100644 --- a/src/Schema.hs +++ b/src/Schema.hs @@ -13,15 +13,11 @@ -- |Module used for defining the database schema module Schema where -import Data.ByteString (ByteString) -import Data.ByteString.UTF8 (fromString) import Data.Int (Int) import Data.Scientific import Data.Text import Data.Time.Calendar import Database.Beam -import Database.Beam.Postgres -import Database.Beam.Schema.Tables -- datatypes -- |Data representing a person in the database From df945e9d84812e2aeaf97fa6bf171ae3dba778b6 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 13 Sep 2019 13:38:41 +0200 Subject: [PATCH 12/73] Add exceptions management --- src/Query.hs | 466 ++++++++++++++++++++++++++++----------------------- 1 file changed, 258 insertions(+), 208 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 0cb6b5b..8d426f8 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -14,7 +14,8 @@ -- |Module used for the queries in the database module Query where -import Data.ByteString.UTF8 (fromString) +import Control.Exception +import Data.ByteString.UTF8 (toString, fromString) import Data.Int (Int) import Data.Scientific import Data.Text @@ -33,8 +34,12 @@ createUri user pswd = "postgres://" ++ user ++ ":" ++ pswd ++ "@localhost/FabLab connect :: String -> IO Connection connect uri = connectPostgreSQL $ fromString uri +-- |Given a connection, close it +closeConnection :: Connection -> IO () +closeConnection = close + runBeam :: Connection -> Pg a -> IO a -runBeam = runBeamPostgresDebug putStrLn -- change for debug or production purposes +runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production purposes allElementsOfTable :: (Table t, BeamSqlBackend be) @@ -56,12 +61,12 @@ allElementsOfTable table = all_ (table fabLabDB) -> Maybe (t (QExpr Postgres QBaseScope) -> QExpr Postgres QBaseScope Bool) -> Connection - -> IO [t Identity]-} + -> IO (Either SomeException [t Identity])-} genericSelect table maybeFilter = let pool = case maybeFilter of Nothing -> allElementsOfTable table Just f -> filter_ f $ allElementsOfTable table - in \conn -> + in \conn -> try $ runBeam conn $ runSelectReturningList $ select pool @@ -76,28 +81,28 @@ prepareName = toTitle . pack -- people queries -- |Select all people in the database -selectAllPeople :: Connection -> IO [Person] +selectAllPeople :: Connection -> IO (Either SqlError [Person]) selectAllPeople = genericSelect _persone Nothing -- |Select all laser cutter operators in the database -selectAllLaserCutterOperators :: Connection -> IO [Person] +selectAllLaserCutterOperators :: Connection -> IO (Either SqlError [Person]) selectAllLaserCutterOperators = genericSelect _persone $ Just (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) -- |Select all 3D printer operators in the database -selectAllPrinterOperators :: Connection -> IO [Person] +selectAllPrinterOperators :: Connection -> IO (Either SqlError [Person]) selectAllPrinterOperators = genericSelect _persone $ Just (\p -> _personOperatoreStampante p ==. (val_ True)) -- |Select all people with the given cf (should be 0 or 1) in the database -selectPersonFromCF :: String -> (Connection -> IO [Person]) +selectPersonFromCF :: String -> (Connection -> IO (Either SqlError [Person])) selectPersonFromCF cf = genericSelect _persone $ Just (\p -> _personCf p ==. (val_ (pack cf))) -- |Add a person to the database -insertPerson :: String -> String -> String -> (Connection -> IO ()) +insertPerson :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPerson cf name surname = - \conn -> + \conn -> try $ runBeam conn $ runInsert $ insert (_persone fabLabDB) @@ -113,9 +118,9 @@ insertPerson cf name surname = ] -- |Modify a person already in the database -modifyPerson :: String -> Bool -> Bool -> Bool -> (Connection -> IO ()) +modifyPerson :: String -> Bool -> Bool -> Bool -> (Connection -> IO (Either SqlError ())) modifyPerson cf partner cutter printer = - \conn -> + \conn -> try $ runBeam conn $ runUpdate $ update (_persone fabLabDB) @@ -130,39 +135,42 @@ modifyPerson cf partner cutter printer = -- materials queries -- |Select all materials in the database -selectAllMaterials :: Connection -> IO [Material] +selectAllMaterials :: Connection -> IO (Either SqlError [Material]) selectAllMaterials = genericSelect _materiali Nothing -- |Select all classes of materials in the database -selectAllMaterialsClasses :: Connection -> IO [MaterialsClass] +selectAllMaterialsClasses :: Connection -> IO (Either SqlError [MaterialsClass]) selectAllMaterialsClasses = genericSelect _classi_di_materiali Nothing -- |Select all the materials classes with the given code (should be 1 or 0) in the database -selectMaterialsClassFromCode :: String -> (Connection -> IO [MaterialsClass]) +selectMaterialsClassFromCode :: String -> (Connection -> IO (Either SqlError [MaterialsClass])) selectMaterialsClassFromCode code = genericSelect _classi_di_materiali $ Just (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) -- |Select all materials with the given code (should be 1 or 0) in the database -selectMaterialFromCode :: String -> (Connection -> IO [Material]) +selectMaterialFromCode :: String -> (Connection -> IO (Either SqlError [Material])) selectMaterialFromCode code = genericSelect _materiali $ Just (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) -- |Select all materials of a given class in the database -selectMaterialsByClass :: String -> (Connection -> IO [Material]) +selectMaterialsByClass :: String -> (Connection -> IO (Either SqlError [Material])) selectMaterialsByClass classCode = \conn -> do - classes <- (selectMaterialsClassFromCode classCode) conn - let mClass = Prelude.head classes :: MaterialsClass - in runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) - $ allElementsOfTable _materiali + selectedClasses <- (selectMaterialsClassFromCode classCode) conn + case selectedClasses of + Left ex -> pure $ Left ex + Right classes -> + let mClass = Prelude.head classes + in try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) + $ allElementsOfTable _materiali -- |Add a class of materials to the database in the database -insertMaterialsClass :: String -> String -> (Connection -> IO ()) +insertMaterialsClass :: String -> String -> (Connection -> IO (Either SqlError ())) insertMaterialsClass code name = - \conn -> + \conn -> try $ runBeam conn $ runInsert $ insert (_classi_di_materiali fabLabDB) @@ -173,58 +181,64 @@ insertMaterialsClass code name = ] -- |Add a material to the database. The code is the id of the material inside the materials class. -insertMaterial :: String -> String -> String -> Double -> String -> (Connection -> IO ()) +insertMaterial :: String -> String -> String -> Double -> String -> (Connection -> IO (Either SqlError ())) insertMaterial code classCode name width descr = \conn -> do - classes <- (selectMaterialsClassFromCode classCode) conn - let mClass = Prelude.head classes :: MaterialsClass - in runBeam conn - $ runInsert - $ insert (_materiali fabLabDB) - $ insertValues - [ Material - (pk mClass) - (prepareCode (classCode ++ code)) - (prepareName name) - width - (pack descr) - ] + selectedClasses <- (selectMaterialsClassFromCode classCode) conn + case selectedClasses of + Left ex -> pure $ Left ex + Right classes -> + let mClass = Prelude.head classes + in try $ runBeam conn + $ runInsert + $ insert (_materiali fabLabDB) + $ insertValues + [ Material + (pk mClass) + (prepareCode (classCode ++ code)) + (prepareName name) + width + (pack descr) + ] -- processings queries -- |Select the processing with the given code in the database -selectProcessingFromCode :: String -> (Connection -> IO [Processing]) +selectProcessingFromCode :: String -> (Connection -> IO (Either SqlError [Processing])) selectProcessingFromCode pCode = genericSelect _lavorazioni $ Just (\p -> _processingCodiceLavorazione p ==. val_ (prepareCode pCode)) -- |Select all processings in the database -selectAllProcessings :: Connection -> IO [Processing] +selectAllProcessings :: Connection -> IO (Either SqlError [Processing]) selectAllProcessings = genericSelect _lavorazioni Nothing -- |Select all types of processing in the database -selectAllTypes :: Connection -> IO [Type] +selectAllTypes :: Connection -> IO (Either SqlError [Type]) selectAllTypes = genericSelect _tipi Nothing -- |Select all types of processing with the given code (should be 1 or 0) in the database -selectTypeFromCode :: String -> (Connection -> IO [Type]) +selectTypeFromCode :: String -> (Connection -> IO (Either SqlError [Type])) selectTypeFromCode code = genericSelect _tipi $ Just (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) -- |Select all processings on a given material in the database -selectProcessingsByMaterials :: String -> (Connection -> IO [Processing]) +selectProcessingsByMaterials :: String -> (Connection -> IO (Either SqlError [Processing])) selectProcessingsByMaterials mCode = \conn -> do - materials <- (selectMaterialFromCode mCode) conn - let material = Prelude.head materials :: Material - in runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) - $ allElementsOfTable _lavorazioni + selectedMaterials <- (selectMaterialFromCode mCode) conn + case selectedMaterials of + Left ex -> pure $ Left ex + Right materials -> + let material = Prelude.head materials + in try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) + $ allElementsOfTable _lavorazioni -- |Add a type of processing to the database -insertType :: String -> String -> String -> (Connection -> IO ()) +insertType :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertType code name descr = - \conn -> + \conn -> try $ runBeam conn $ runInsert $ insert (_tipi fabLabDB) @@ -236,63 +250,71 @@ insertType code name descr = ] -- |Add a new processing to the database -insertProcessing :: String -> String -> Int -> Int -> Int -> String -> (Connection -> IO ()) +insertProcessing :: String -> String -> Int -> Int -> Int -> String -> (Connection -> IO (Either SqlError ())) insertProcessing typeCode materialCode maxPotency minPotency speed descr = \conn -> do - types <- (selectTypeFromCode typeCode) conn - materials <- (selectMaterialFromCode materialCode) conn - let pType = Prelude.head types :: Type - material = Prelude.head materials :: Material - code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode - in runBeam conn - $ runInsert - $ insert (_lavorazioni fabLabDB) - $ insertValues - [ Processing - (pk pType) - (prepareCode code) - (pk material) - maxPotency - minPotency - speed - (pack descr) - ] + selectedTypes <- (selectTypeFromCode typeCode) conn + selectedMaterials <- (selectMaterialFromCode materialCode) conn + case (selectedTypes, selectedMaterials) of + (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> pure $ Left ex + (_, Left ex) -> pure $ Left ex + (Right types, Right materials) -> + let pType = Prelude.head types :: Type + material = Prelude.head materials :: Material + code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode + in try $ runBeam conn + $ runInsert + $ insert (_lavorazioni fabLabDB) + $ insertValues + [ Processing + (pk pType) + (prepareCode code) + (pk material) + maxPotency + minPotency + speed + (pack descr) + ] -- plastics and filaments queries -- |Select all filaments in the database -selectAllFilaments :: Connection -> IO [Filament] +selectAllFilaments :: Connection -> IO (Either SqlError [Filament]) selectAllFilaments = genericSelect _filamenti Nothing -- |Select all plastics in the database -selectAllPlastics :: Connection -> IO [Plastic] +selectAllPlastics :: Connection -> IO (Either SqlError [Plastic]) selectAllPlastics = genericSelect _plastiche Nothing -- |Select all the plastics with the given code (should be 1 or 0) in the database -selectPlasticFromCode :: String -> (Connection -> IO [Plastic]) +selectPlasticFromCode :: String -> (Connection -> IO (Either SqlError [Plastic])) selectPlasticFromCode code = genericSelect _plastiche $ Just (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) -- |Select all the filaments with the given code (should be 1 or 0) in the database -selectFilamentFromCode :: String -> (Connection -> IO [Filament]) +selectFilamentFromCode :: String -> (Connection -> IO (Either SqlError [Filament])) selectFilamentFromCode code = genericSelect _filamenti $ Just (\f -> _filamentCodiceFilamento f ==. (val_ (prepareCode code))) -- |Select the filaments made of a given plastic in the database -selectFilamentsByPlastic :: String -> (Connection -> IO [Filament]) -selectFilamentsByPlastic pCode = +selectFilamentsByPlastic :: String -> (Connection -> IO (Either SqlError [Filament])) +selectFilamentsByPlastic plasticCode = \conn -> do - plastics <- (selectPlasticFromCode pCode) conn - let plastic = Prelude.head plastics :: Plastic - in runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) - $ allElementsOfTable _filamenti + selectedPlastics <- (selectPlasticFromCode plasticCode) conn + case selectedPlastics of + Left ex -> pure $ Left ex + Right plastics -> + let plastic = Prelude.head plastics :: Plastic + in try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) + $ allElementsOfTable _filamenti -- |Add a type of plastic to the database -insertPlastic :: String -> String -> String -> (Connection -> IO ()) +insertPlastic :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPlastic code name descr = - \conn -> + \conn -> try $ runBeam conn $ runInsert $ insert (_plastiche fabLabDB) @@ -304,36 +326,39 @@ insertPlastic code name descr = ] -- |Add a filament to the database. The code is the id of the filament inside the type of plastic -insertFilament :: String -> String -> String -> String -> (Connection -> IO ()) +insertFilament :: String -> String -> String -> String -> (Connection -> IO (Either SqlError ())) insertFilament code plasticCode brand color = \conn -> do - plastics <- (selectPlasticFromCode plasticCode) conn - let plastic = Prelude.head plastics :: Plastic - in runBeam conn - $ runInsert - $ insert (_filamenti fabLabDB) - $ insertValues - [ Filament - (prepareCode code) - (pk plastic) - (prepareName brand) - (prepareName color) - ] + selectedPlastics <- (selectPlasticFromCode plasticCode) conn + case selectedPlastics of + Left ex -> pure $ Left ex + Right plastics -> + let plastic = Prelude.head plastics + in try $ runBeam conn + $ runInsert + $ insert (_filamenti fabLabDB) + $ insertValues + [ Filament + (prepareCode code) + (pk plastic) + (prepareName brand) + (prepareName color) + ] -- printers queries -- |Select all printers in the database -selectAllPrinters :: Connection -> IO [Printer] +selectAllPrinters :: Connection -> IO (Either SqlError [Printer]) selectAllPrinters = genericSelect _stampanti Nothing -- |Select all the printers with the given code (should be 0 or 1) in the database -selectPrinterFromCode :: String -> (Connection -> IO [Printer]) +selectPrinterFromCode :: String -> (Connection -> IO (Either SqlError [Printer])) selectPrinterFromCode code = genericSelect _stampanti $ Just (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) -- |Add a printer to the database -insertPrinter :: String -> String -> String -> String -> (Connection -> IO ()) +insertPrinter :: String -> String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPrinter code brand model descr = - \conn -> do + \conn -> try $ runBeam conn $ runInsert $ insert (_stampanti fabLabDB) @@ -346,95 +371,109 @@ insertPrinter code brand model descr = ] -- |Assign a printer to a print -assignPrinter :: String -> Int -> (Connection -> IO ()) +assignPrinter :: String -> Int -> (Connection -> IO (Either SqlError ())) assignPrinter printerCode printCode = \conn -> do - printers <- (selectPrinterFromCode printerCode) conn - let printer = Prelude.head printers - in runBeam conn - $ runUpdate - $ update (_stampe fabLabDB) - (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) - (\s -> _printCodiceStampa s ==. (val_ printCode)) + selectedPrinters <- (selectPrinterFromCode printerCode) conn + case selectedPrinters of + Left ex -> pure $ Left ex + Right printers -> + let printer = Prelude.head printers + in try $ runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) + (\s -> _printCodiceStampa s ==. (val_ printCode)) -- prints queries -- |Select the print with the given code in the database (should be 0 or 1) -selectPrintFromCode :: Int -> (Connection -> IO [Print]) +selectPrintFromCode :: Int -> (Connection -> IO (Either SqlError [Print])) selectPrintFromCode pCode = genericSelect _stampe $ Just (\p -> _printCodiceStampa p ==. val_ pCode) -- |Select all prints in the database -selectAllPrints :: Connection -> IO [Print] +selectAllPrints :: Connection -> IO (Either SqlError [Print]) selectAllPrints = genericSelect _stampe Nothing -- |Select all the print that aren't completed in the database -selectAllIncompletePrints :: Connection -> IO [Print] +selectAllIncompletePrints :: Connection -> IO (Either SqlError [Print]) selectAllIncompletePrints = genericSelect _stampe $ Just (\p -> _printDataConsegna p ==. val_ Nothing) -- |Select all the completed prints in the database -selectAllCompletePrints :: Connection -> IO [Print] +selectAllCompletePrints :: Connection -> IO (Either SqlError [Print]) selectAllCompletePrints = genericSelect _stampe $ Just (\p -> _printDataConsegna p /=. val_ Nothing) -- |Add a new print to the database -insertPrint :: String -> Day -> String -> (Connection -> IO ()) +insertPrint :: String -> Day -> String -> (Connection -> IO (Either SqlError ())) insertPrint cf insertDate descr = \conn -> do - people <- (selectPersonFromCF cf) conn - let person = Prelude.head people :: Person - in runBeam conn - $ runInsert - $ insert (_stampe fabLabDB) - $ insertExpressions - [ Print - { _printCodiceStampa = default_, - _printDataRichiesta = val_ insertDate, - _printDataConsegna = val_ Nothing, - _printTempo = val_ Nothing, - _printCostoMateriali = val_ Nothing, - _printCostoTotale = val_ Nothing, - _printDescrizione = val_ (pack descr), - _printCfRichiedente = val_ (pk person), - _printCfIncaricato = nothing_, - _printCodiceStampante = nothing_ - } - ] + selectedPeople <- (selectPersonFromCF cf) conn + case selectedPeople of + Left ex -> pure $ Left ex + Right people -> + let person = Prelude.head people + in try $ runBeam conn + $ runInsert + $ insert (_stampe fabLabDB) + $ insertExpressions + [ Print + { _printCodiceStampa = default_, + _printDataRichiesta = val_ insertDate, + _printDataConsegna = val_ Nothing, + _printTempo = val_ Nothing, + _printCostoMateriali = val_ Nothing, + _printCostoTotale = val_ Nothing, + _printDescrizione = val_ (pack descr), + _printCfRichiedente = val_ (pk person), + _printCfIncaricato = nothing_, + _printCodiceStampante = nothing_ + } + ] -- |Assign a print to an operator -assignPrint :: Int -> String -> (Connection -> IO ()) +assignPrint :: Int -> String -> (Connection -> IO (Either SqlError ())) assignPrint code cf = \conn -> do - operators <- (selectPersonFromCF cf) conn - let operator = Prelude.head operators - in runBeam conn - $ runUpdate - $ update (_stampe fabLabDB) - (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) - (\s -> _printCodiceStampa s ==. val_ code) + selectedOperators <- (selectPersonFromCF cf) conn + case selectedOperators of + Left ex -> pure $ Left ex + Right operators -> + let operator = Prelude.head operators + in try $ runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) + (\s -> _printCodiceStampa s ==. val_ code) -- |Assign a filament to a print in the database -assignFilament :: Int -> String -> (Connection -> IO ()) +assignFilament :: Int -> String -> (Connection -> IO (Either SqlError ())) assignFilament pCode fCode = \conn -> do - filaments <- (selectFilamentFromCode fCode) conn - prints <- (selectPrintFromCode pCode) conn - let filament = Prelude.head filaments - selectedPrint = Prelude.head prints - in runBeam conn - $ runInsert - $ insert (_usi fabLabDB) - $ insertExpressions - [ Use - { _useCodiceFilamento = val_ (pk filament), - _useCodiceStampa = val_ (pk selectedPrint) - } - ] + selectedFilaments <- (selectFilamentFromCode fCode) conn + selectedPrints <- (selectPrintFromCode pCode) conn + case (selectedFilaments, selectedPrints) of + (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> pure $ Left ex + (_, Left ex) -> pure $ Left ex + (Right filaments, Right prints) -> + let filament = Prelude.head filaments + selectedPrint = Prelude.head prints + in try $ runBeam conn + $ runInsert + $ insert (_usi fabLabDB) + $ insertExpressions + [ Use + { _useCodiceFilamento = val_ (pk filament), + _useCodiceStampa = val_ (pk selectedPrint) + } + ] -- |Complete a print -completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completePrint pCode deliveryDate workTime total materials = - \conn -> + \conn -> try $ runBeam conn $ runUpdate $ update (_stampe fabLabDB) @@ -450,81 +489,92 @@ completePrint pCode deliveryDate workTime total materials = -- cuts queries -- |Select the cut with the given code in the database (should be 0 or 1) -selectCutFromCode :: Int -> (Connection -> IO [Cut]) +selectCutFromCode :: Int -> (Connection -> IO (Either SqlError [Cut])) selectCutFromCode cCode = genericSelect _intagli $ Just (\c -> _cutCodiceIntaglio c ==. val_ cCode) -- |Select all cuts in the database -selectAllCuts :: Connection -> IO [Cut] +selectAllCuts :: Connection -> IO (Either SqlError [Cut]) selectAllCuts = genericSelect _intagli Nothing -- |Select all the print that aren't completed in the database -selectAllIncompleteCuts :: Connection -> IO [Cut] +selectAllIncompleteCuts :: Connection -> IO (Either SqlError [Cut]) selectAllIncompleteCuts = genericSelect _intagli $ Just (\c -> _cutDataConsegna c ==. val_ Nothing) -- |Select all the completed prints in the database -selectAllCompleteCuts :: Connection -> IO [Cut] +selectAllCompleteCuts :: Connection -> IO (Either SqlError [Cut]) selectAllCompleteCuts = genericSelect _intagli $ Just (\c -> _cutDataConsegna c /=. val_ Nothing) -- |Add a new cut to the database -insertCut :: String -> Day -> String -> (Connection -> IO ()) +insertCut :: String -> Day -> String -> (Connection -> IO (Either SqlError ())) insertCut cf insertDate descr = \conn -> do - people <- selectPersonFromCF cf conn - let person = Prelude.head people :: Person - in runBeam conn - $ runInsert - $ insert (_intagli fabLabDB) - $ insertExpressions - [ Cut - { _cutCodiceIntaglio = default_, - _cutDataRichiesta = val_ insertDate, - _cutDataConsegna = val_ Nothing, - _cutTempo = val_ Nothing, - _cutCostoMateriali = val_ Nothing, - _cutCostoTotale = val_ Nothing, - _cutDescrizione = val_ (pack descr), - _cutCfRichiedente = val_ (pk person), - _cutCfIncaricato = nothing_ - } - ] + selectedPeople <- selectPersonFromCF cf conn + case selectedPeople of + Left ex -> pure $ Left ex + Right people -> + let person = Prelude.head people + in try $ runBeam conn + $ runInsert + $ insert (_intagli fabLabDB) + $ insertExpressions + [ Cut + { _cutCodiceIntaglio = default_, + _cutDataRichiesta = val_ insertDate, + _cutDataConsegna = val_ Nothing, + _cutTempo = val_ Nothing, + _cutCostoMateriali = val_ Nothing, + _cutCostoTotale = val_ Nothing, + _cutDescrizione = val_ (pack descr), + _cutCfRichiedente = val_ (pk person), + _cutCfIncaricato = nothing_ + } + ] -- |Assign a cut to an operator -assignCut :: Int -> String -> (Connection -> IO ()) +assignCut :: Int -> String -> (Connection -> IO (Either SqlError ())) assignCut code cf = \conn -> do - operators <- (selectPersonFromCF cf) conn - let operator = Prelude.head operators - in runBeam conn - $ runUpdate - $ update (_intagli fabLabDB) - (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) - (\c -> _cutCodiceIntaglio c ==. val_ code) + selectedOperators <- (selectPersonFromCF cf) conn + case selectedOperators of + Left ex -> pure $ Left ex + Right operators -> + let operator = Prelude.head operators + in try $ runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) + (\c -> _cutCodiceIntaglio c ==. val_ code) -- |Assign a processing to a print -assignProcessing :: Int -> String -> (Connection -> IO ()) +assignProcessing :: Int -> String -> (Connection -> IO (Either SqlError ())) assignProcessing cCode pCode = \conn -> do - processings <- (selectProcessingFromCode pCode) conn - cuts <- (selectCutFromCode cCode) conn - let processing = Prelude.head processings - cut = Prelude.head cuts - in runBeam conn - $ runInsert - $ insert (_composizioni fabLabDB) - $ insertExpressions - [ Composition - { _compositionCodiceLavorazione = val_ (pk processing), - _compositionCodiceIntaglio = val_ (pk cut) - } - ] + selectedProcessings <- (selectProcessingFromCode pCode) conn + selectedCuts <- (selectCutFromCode cCode) conn + case (selectedProcessings, selectedCuts) of + (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> pure $ Left ex + (_, Left ex) -> pure $ Left ex + (Right processings, Right cuts) -> do + let processing = Prelude.head processings + cut = Prelude.head cuts + in try $ runBeam conn + $ runInsert + $ insert (_composizioni fabLabDB) + $ insertExpressions + [ Composition + { _compositionCodiceLavorazione = val_ (pk processing), + _compositionCodiceIntaglio = val_ (pk cut) + } + ] -- |Complete a cut -completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO ()) +completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completeCut code deliveryDate workTime total materials = - \conn -> + \conn -> try $ runBeam conn $ runUpdate $ update (_intagli fabLabDB) From 19f0868b99624d8ae410a911a3ddd71910397a06 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 13 Sep 2019 13:51:37 +0200 Subject: [PATCH 13/73] Fix formatting --- src/Query.hs | 221 +++++++++++++++++++++++++++------------------------ 1 file changed, 115 insertions(+), 106 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 8d426f8..3b33ee6 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -15,7 +15,7 @@ module Query where import Control.Exception -import Data.ByteString.UTF8 (toString, fromString) +import Data.ByteString.UTF8 (fromString, toString) import Data.Int (Int) import Data.Scientific import Data.Text @@ -66,8 +66,9 @@ genericSelect table maybeFilter = let pool = case maybeFilter of Nothing -> allElementsOfTable table Just f -> filter_ f $ allElementsOfTable table - in \conn -> try $ - runBeam conn + in \conn -> + try + $ runBeam conn $ runSelectReturningList $ select pool @@ -102,8 +103,9 @@ selectPersonFromCF cf = -- |Add a person to the database insertPerson :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPerson cf name surname = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runInsert $ insert (_persone fabLabDB) $ insertValues @@ -120,8 +122,9 @@ insertPerson cf name surname = -- |Modify a person already in the database modifyPerson :: String -> Bool -> Bool -> Bool -> (Connection -> IO (Either SqlError ())) modifyPerson cf partner cutter printer = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runUpdate $ update (_persone fabLabDB) ( \p -> @@ -161,7 +164,7 @@ selectMaterialsByClass classCode = Left ex -> pure $ Left ex Right classes -> let mClass = Prelude.head classes - in try $ runBeam conn + in try $ runBeam conn $ runSelectReturningList $ select $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) @@ -170,8 +173,9 @@ selectMaterialsByClass classCode = -- |Add a class of materials to the database in the database insertMaterialsClass :: String -> String -> (Connection -> IO (Either SqlError ())) insertMaterialsClass code name = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runInsert $ insert (_classi_di_materiali fabLabDB) $ insertValues @@ -189,7 +193,7 @@ insertMaterial code classCode name width descr = Left ex -> pure $ Left ex Right classes -> let mClass = Prelude.head classes - in try $ runBeam conn + in try $ runBeam conn $ runInsert $ insert (_materiali fabLabDB) $ insertValues @@ -227,9 +231,9 @@ selectProcessingsByMaterials mCode = selectedMaterials <- (selectMaterialFromCode mCode) conn case selectedMaterials of Left ex -> pure $ Left ex - Right materials -> + Right materials -> let material = Prelude.head materials - in try $ runBeam conn + in try $ runBeam conn $ runSelectReturningList $ select $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) @@ -238,8 +242,9 @@ selectProcessingsByMaterials mCode = -- |Add a type of processing to the database insertType :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertType code name descr = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runInsert $ insert (_tipi fabLabDB) $ insertValues @@ -260,22 +265,22 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = (Left ex, _) -> pure $ Left ex (_, Left ex) -> pure $ Left ex (Right types, Right materials) -> - let pType = Prelude.head types :: Type - material = Prelude.head materials :: Material - code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode - in try $ runBeam conn - $ runInsert - $ insert (_lavorazioni fabLabDB) - $ insertValues - [ Processing - (pk pType) - (prepareCode code) - (pk material) - maxPotency - minPotency - speed - (pack descr) - ] + let pType = Prelude.head types :: Type + material = Prelude.head materials :: Material + code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode + in try $ runBeam conn + $ runInsert + $ insert (_lavorazioni fabLabDB) + $ insertValues + [ Processing + (pk pType) + (prepareCode code) + (pk material) + maxPotency + minPotency + speed + (pack descr) + ] -- plastics and filaments queries -- |Select all filaments in the database @@ -304,18 +309,19 @@ selectFilamentsByPlastic plasticCode = case selectedPlastics of Left ex -> pure $ Left ex Right plastics -> - let plastic = Prelude.head plastics :: Plastic - in try $ runBeam conn - $ runSelectReturningList - $ select + let plastic = Prelude.head plastics :: Plastic + in try $ runBeam conn + $ runSelectReturningList + $ select $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) $ allElementsOfTable _filamenti -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPlastic code name descr = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runInsert $ insert (_plastiche fabLabDB) $ insertValues @@ -333,17 +339,17 @@ insertFilament code plasticCode brand color = case selectedPlastics of Left ex -> pure $ Left ex Right plastics -> - let plastic = Prelude.head plastics - in try $ runBeam conn - $ runInsert - $ insert (_filamenti fabLabDB) - $ insertValues - [ Filament - (prepareCode code) - (pk plastic) - (prepareName brand) - (prepareName color) - ] + let plastic = Prelude.head plastics + in try $ runBeam conn + $ runInsert + $ insert (_filamenti fabLabDB) + $ insertValues + [ Filament + (prepareCode code) + (pk plastic) + (prepareName brand) + (prepareName color) + ] -- printers queries -- |Select all printers in the database @@ -358,8 +364,9 @@ selectPrinterFromCode code = -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO (Either SqlError ())) insertPrinter code brand model descr = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runInsert $ insert (_stampanti fabLabDB) $ insertValues @@ -379,7 +386,7 @@ assignPrinter printerCode printCode = Left ex -> pure $ Left ex Right printers -> let printer = Prelude.head printers - in try $ runBeam conn + in try $ runBeam conn $ runUpdate $ update (_stampe fabLabDB) (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) @@ -414,7 +421,7 @@ insertPrint cf insertDate descr = Left ex -> pure $ Left ex Right people -> let person = Prelude.head people - in try $ runBeam conn + in try $ runBeam conn $ runInsert $ insert (_stampe fabLabDB) $ insertExpressions @@ -439,9 +446,9 @@ assignPrint code cf = selectedOperators <- (selectPersonFromCF cf) conn case selectedOperators of Left ex -> pure $ Left ex - Right operators -> + Right operators -> let operator = Prelude.head operators - in try $ runBeam conn + in try $ runBeam conn $ runUpdate $ update (_stampe fabLabDB) (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) @@ -457,24 +464,25 @@ assignFilament pCode fCode = (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) (Left ex, _) -> pure $ Left ex (_, Left ex) -> pure $ Left ex - (Right filaments, Right prints) -> - let filament = Prelude.head filaments - selectedPrint = Prelude.head prints - in try $ runBeam conn - $ runInsert - $ insert (_usi fabLabDB) - $ insertExpressions - [ Use - { _useCodiceFilamento = val_ (pk filament), - _useCodiceStampa = val_ (pk selectedPrint) - } - ] + (Right filaments, Right prints) -> + let filament = Prelude.head filaments + selectedPrint = Prelude.head prints + in try $ runBeam conn + $ runInsert + $ insert (_usi fabLabDB) + $ insertExpressions + [ Use + { _useCodiceFilamento = val_ (pk filament), + _useCodiceStampa = val_ (pk selectedPrint) + } + ] -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completePrint pCode deliveryDate workTime total materials = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runUpdate $ update (_stampe fabLabDB) ( \s -> @@ -514,24 +522,24 @@ insertCut cf insertDate descr = selectedPeople <- selectPersonFromCF cf conn case selectedPeople of Left ex -> pure $ Left ex - Right people -> - let person = Prelude.head people - in try $ runBeam conn - $ runInsert - $ insert (_intagli fabLabDB) - $ insertExpressions - [ Cut - { _cutCodiceIntaglio = default_, - _cutDataRichiesta = val_ insertDate, - _cutDataConsegna = val_ Nothing, - _cutTempo = val_ Nothing, - _cutCostoMateriali = val_ Nothing, - _cutCostoTotale = val_ Nothing, - _cutDescrizione = val_ (pack descr), - _cutCfRichiedente = val_ (pk person), - _cutCfIncaricato = nothing_ - } - ] + Right people -> + let person = Prelude.head people + in try $ runBeam conn + $ runInsert + $ insert (_intagli fabLabDB) + $ insertExpressions + [ Cut + { _cutCodiceIntaglio = default_, + _cutDataRichiesta = val_ insertDate, + _cutDataConsegna = val_ Nothing, + _cutTempo = val_ Nothing, + _cutCostoMateriali = val_ Nothing, + _cutCostoTotale = val_ Nothing, + _cutDescrizione = val_ (pack descr), + _cutCfRichiedente = val_ (pk person), + _cutCfIncaricato = nothing_ + } + ] -- |Assign a cut to an operator assignCut :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -540,13 +548,13 @@ assignCut code cf = selectedOperators <- (selectPersonFromCF cf) conn case selectedOperators of Left ex -> pure $ Left ex - Right operators -> - let operator = Prelude.head operators - in try $ runBeam conn - $ runUpdate - $ update (_intagli fabLabDB) - (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) - (\c -> _cutCodiceIntaglio c ==. val_ code) + Right operators -> + let operator = Prelude.head operators + in try $ runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) + (\c -> _cutCodiceIntaglio c ==. val_ code) -- |Assign a processing to a print assignProcessing :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -559,23 +567,24 @@ assignProcessing cCode pCode = (Left ex, _) -> pure $ Left ex (_, Left ex) -> pure $ Left ex (Right processings, Right cuts) -> do - let processing = Prelude.head processings - cut = Prelude.head cuts - in try $ runBeam conn - $ runInsert - $ insert (_composizioni fabLabDB) - $ insertExpressions - [ Composition - { _compositionCodiceLavorazione = val_ (pk processing), - _compositionCodiceIntaglio = val_ (pk cut) - } - ] + let processing = Prelude.head processings + cut = Prelude.head cuts + in try $ runBeam conn + $ runInsert + $ insert (_composizioni fabLabDB) + $ insertExpressions + [ Composition + { _compositionCodiceLavorazione = val_ (pk processing), + _compositionCodiceIntaglio = val_ (pk cut) + } + ] -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completeCut code deliveryDate workTime total materials = - \conn -> try $ - runBeam conn + \conn -> + try + $ runBeam conn $ runUpdate $ update (_intagli fabLabDB) ( \c -> From 9f4a8b2498efc9d3bf77f60fec6d328b0e5e8645 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 13 Sep 2019 16:36:09 +0200 Subject: [PATCH 14/73] Change to connection methods --- src/Query.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 3b33ee6..c7ba889 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -26,13 +26,17 @@ import Database.Beam.Postgres import Schema -- constants and general functions --- |Creates an uri for connecting to the database with the given username and password +-- |Creates a standard uri for connecting to the database with the given username and password createUri :: String -> String -> String createUri user pswd = "postgres://" ++ user ++ ":" ++ pswd ++ "@localhost/FabLab" -- |Given an uri, returns a connection to the database -connect :: String -> IO Connection -connect uri = connectPostgreSQL $ fromString uri +connectWithUri :: String -> IO Connection +connectWithUri uri = connectPostgreSQL $ fromString uri + +-- |Connects to the database with the given characteristics +connectWithInfo :: String -> Integer -> String -> String -> String -> IO Connection +connectWithInfo host port user pswd db = connect $ ConnectInfo host (fromInteger port) user pswd db -- |Given a connection, close it closeConnection :: Connection -> IO () From 898204516273b96c9991e7d2b7526a9df1a6c580 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 15 Sep 2019 18:06:11 +0200 Subject: [PATCH 15/73] Add base skeleton of server --- app/Main.hs | 8 +- package.yaml | 14 ++- src/Server.hs | 242 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 259 insertions(+), 5 deletions(-) create mode 100644 src/Server.hs diff --git a/app/Main.hs b/app/Main.hs index af39698..a7f1eb4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Schema +import Server import Query +configFile :: FilePath +configFile = "server.cfg" + main :: IO () -main = putStrLn "main" +main = parseConfig configFile >>= runServer diff --git a/package.yaml b/package.yaml index 699e416..32ebf99 100644 --- a/package.yaml +++ b/package.yaml @@ -20,16 +20,22 @@ extra-source-files: description: Please see the README on GitHub at dependencies: +- aeson - base >= 4.7 && < 5 -- Spock >= 0.11 -- mtl -- text - beam-core - beam-postgres - bytestring -- utf8-string +- configurator +- hvect +- mtl - scientific +- Spock >= 0.11 +- text - time +- transformers +- users +- users-postgresql-simple +- utf8-string library: source-dirs: src diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..05066c8 --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- |Module used for the connectivity part of the application +module Server where + +import Control.Exception +import Control.Monad.Trans.Maybe +import Data.Aeson hiding (json) +import qualified Data.Configurator as C +import Data.HVect +import Data.Text +import Data.Text.Encoding +import Database.Beam +import Database.Beam.Postgres (Connection, sqlErrorMsg) +import GHC.Generics +import Query +import Schema +import Web.Spock +import Web.Spock.Config +import Web.Users.Postgresql +import Web.Users.Types (SessionId, User, UserStorageBackend, getUserById, verifySession) + +-- datatypes +data IsGuest = IsGuest + +-- app :: SpockM conn sess st () +-- SpockM conn sess st = SpockCtxM () conn sess st +-- SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) +type SessionVal = Maybe Web.Users.Types.SessionId + +type Api ctx = SpockCtxM ctx Connection SessionVal () () + +type ApiAction ctx a = SpockActionCtx ctx Connection SessionVal () a + +-- utility functions and constants +data ApiCfg + = ApiCfg + { acfg_db :: Text, + acfg_db_location :: Text, + acfg_db_port :: Integer, + acfg_db_user :: Text, + acfg_db_pswd :: Text, + acfg_port :: Int, + acfg_name :: Text + } + +-- |Parses the configuration file +parseConfig :: FilePath -> IO ApiCfg +parseConfig cfgFile = do + cfg <- C.load [C.Required cfgFile] + db <- C.require cfg "db" + dbLocation <- C.require cfg "dbLocation" + dbPort <- C.require cfg "dbPort" + dbUser <- C.require cfg "dbUser" + dbPassword <- C.require cfg "dbPswd" + port <- C.require cfg "port" + name <- C.require cfg "apiName" + return (ApiCfg db dbLocation dbPort dbUser dbPassword port name) + +-- |Function used to get the connection used to interrogate the database +getConnection :: String -> Integer -> String -> String -> String -> PoolOrConn Connection +getConnection host port user pswd name = + PCConn + $ ConnBuilder + (connectWithInfo host port user pswd name) + (closeConnection) + (PoolCfg 1 12 1) + +-- |Produces an error with the given code and description +errorJson :: Int -> Text -> ApiAction ctx () +errorJson code message = + json + $ object + [ "result" .= String "failure", + "error" .= object ["code" .= code, "message" .= message] + ] + +baseHook :: Monad m => ActionCtxT () m (HVect '[]) +baseHook = return HNil + +authHook :: UserStorageBackend conn0 => ActionCtxT (HVect ts1) (WebStateM conn0 SessionVal st) (HVect (User : ts1)) +authHook = do + oldCtx <- getContext + sess <- readSession + mUser <- getUserFromSession + case mUser of + Nothing -> + text "Unknown user. Login first!" + Just val -> + return (val :&: oldCtx) + +getUserFromSession :: UserStorageBackend b0 => ActionCtxT ctx (WebStateM b0 SessionVal st) (Maybe User) +getUserFromSession = + runMaybeT $ do + sessId <- MaybeT readSession + uid <- MaybeT $ runQuery (\conn -> verifySession conn sessId 0) + user <- MaybeT $ runQuery (`getUserById` uid) + return user + +-- server functions +runServer :: ApiCfg -> IO () +runServer cfg = + let conn = + getConnection (unpack $ acfg_db_location cfg) + (acfg_db_port cfg) + (unpack $ acfg_db_user cfg) + (unpack $ acfg_db_pswd cfg) + (unpack $ acfg_db cfg) + in do + spockCfg <- defaultSpockCfg Nothing conn () + runSpock 8080 (spock spockCfg app) + +app :: Api () +app = do + prehook baseHook $ do + get "" $ do + -- sending main page with login form + -- here goes login + queryResult <- runQuery selectAllPeople + case queryResult of + Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex + Right allPeople -> json allPeople + prehook authHook $ do + -- here goes requests for pages and data + get "materials" $ do + queryResult <- runQuery selectAllMaterials + case queryResult of + Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex + Right allMaterials -> json allMaterials + +-- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one +deriving instance FromJSON Person + +deriving instance ToJSON Person + +deriving instance FromJSON PersonId + +deriving instance ToJSON PersonId + +deriving instance FromJSON (PrimaryKey PersonT (Nullable Identity)) + +deriving instance ToJSON (PrimaryKey PersonT (Nullable Identity)) + +deriving instance FromJSON Print + +deriving instance ToJSON Print + +deriving instance FromJSON PrintId + +deriving instance ToJSON PrintId + +deriving instance FromJSON Cut + +deriving instance ToJSON Cut + +deriving instance FromJSON CutId + +deriving instance ToJSON CutId + +deriving instance FromJSON Printer + +deriving instance ToJSON Printer + +deriving instance FromJSON PrinterId + +deriving instance ToJSON PrinterId + +deriving instance FromJSON (PrimaryKey PrinterT (Nullable Identity)) + +deriving instance ToJSON (PrimaryKey PrinterT (Nullable Identity)) + +deriving instance FromJSON Plastic + +deriving instance ToJSON Plastic + +deriving instance FromJSON PlasticId + +deriving instance ToJSON PlasticId + +deriving instance FromJSON Filament + +deriving instance ToJSON Filament + +deriving instance FromJSON FilamentId + +deriving instance ToJSON FilamentId + +deriving instance FromJSON Processing + +deriving instance ToJSON Processing + +deriving instance FromJSON ProcessingId + +deriving instance ToJSON ProcessingId + +deriving instance FromJSON Type + +deriving instance ToJSON Type + +deriving instance FromJSON TypeId + +deriving instance ToJSON TypeId + +deriving instance FromJSON Material + +deriving instance ToJSON Material + +deriving instance FromJSON MaterialId + +deriving instance ToJSON MaterialId + +deriving instance FromJSON MaterialsClass + +deriving instance ToJSON MaterialsClass + +deriving instance FromJSON MaterialsClassId + +deriving instance ToJSON MaterialsClassId + +deriving instance FromJSON Composition + +deriving instance ToJSON Composition + +deriving instance FromJSON CompositionId + +deriving instance ToJSON CompositionId + +deriving instance FromJSON Use + +deriving instance ToJSON Use + +deriving instance FromJSON UseId + +deriving instance ToJSON UseId From 74254ca5c8d65ea2b8168b3880a6e0ef8e014520 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 15 Sep 2019 21:42:00 +0200 Subject: [PATCH 16/73] Add post route for login --- src/Server.hs | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 05066c8..6627144 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -31,16 +31,7 @@ import Web.Users.Types (SessionId, User, UserStorageBackend, getUserById, verify -- datatypes data IsGuest = IsGuest --- app :: SpockM conn sess st () --- SpockM conn sess st = SpockCtxM () conn sess st --- SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) -type SessionVal = Maybe Web.Users.Types.SessionId - -type Api ctx = SpockCtxM ctx Connection SessionVal () () - -type ApiAction ctx a = SpockActionCtx ctx Connection SessionVal () a - --- utility functions and constants +-- |Represents the information necessary to start the application data ApiCfg = ApiCfg { acfg_db :: Text, @@ -52,6 +43,19 @@ data ApiCfg acfg_name :: Text } +-- app :: SpockM conn sess st () +-- SpockM conn sess st = SpockCtxM () conn sess st +-- SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) +type SessionVal = Maybe Web.Users.Types.SessionId + +type Api ctx = SpockCtxM ctx Connection SessionVal () () + +type ApiAction ctx a = SpockActionCtx ctx Connection SessionVal () a + +-- utility functions and constants +getClientFilePath :: String -> FilePath +getClientFilePath fileName = "client/" ++ fileName + -- |Parses the configuration file parseConfig :: FilePath -> IO ApiCfg parseConfig cfgFile = do @@ -105,6 +109,9 @@ getUserFromSession = user <- MaybeT $ runQuery (`getUserById` uid) return user +loginAction :: Text -> Text -> ApiAction ctx () +loginAction user pswd = undefined + -- server functions runServer :: ApiCfg -> IO () runServer cfg = @@ -121,13 +128,14 @@ runServer cfg = app :: Api () app = do prehook baseHook $ do - get "" $ do - -- sending main page with login form - -- here goes login - queryResult <- runQuery selectAllPeople - case queryResult of - Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex - Right allPeople -> json allPeople + get root $ do + file "login form" $ getClientFilePath "login.html" + post "login" $ do + maybeUser <- param "username" + maybePswd <- param "password" + case (maybeUser, maybePswd) of + (Just user, Just pswd) -> loginAction user pswd + (_, _) -> errorJson 400 "Missing parameter" prehook authHook $ do -- here goes requests for pages and data get "materials" $ do From 0d94c1e411618261c211b0a76097a47e67dba8bd Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 19 Sep 2019 09:13:59 +0200 Subject: [PATCH 17/73] Correct queries used to select just one element --- package.yaml | 4 +- src/Query.hs | 391 ++++++++++++++++++++++++++------------------------- 2 files changed, 203 insertions(+), 192 deletions(-) diff --git a/package.yaml b/package.yaml index 32ebf99..b63eee0 100644 --- a/package.yaml +++ b/package.yaml @@ -28,14 +28,14 @@ dependencies: - configurator - hvect - mtl +- postgresql-libpq - scientific - Spock >= 0.11 - text - time - transformers -- users -- users-postgresql-simple - utf8-string +- wai-middleware-static library: source-dirs: src diff --git a/src/Query.hs b/src/Query.hs index c7ba889..ceadee0 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -23,6 +23,7 @@ import Data.Time.Calendar import Database.Beam import Database.Beam.Backend.SQL (BeamSqlBackend) import Database.Beam.Postgres +import Database.PostgreSQL.LibPQ (ExecStatus (NonfatalError)) import Schema -- constants and general functions @@ -53,8 +54,8 @@ allElementsOfTable -> Q be FabLabDB s (t (QExpr be s)) allElementsOfTable table = all_ (table fabLabDB) --- |A generic select with filters -{-genericSelect :: (Table t, Generic (t Identity), +-- |A generic select for list of elements with filters +{-genericSelectList :: (Table t, Generic (t Identity), Generic (t Database.Beam.Backend.Types.Exposed), Database.Beam.Backend.SQL.Row.GFromBackendRow Postgres @@ -66,7 +67,7 @@ allElementsOfTable table = all_ (table fabLabDB) (t (QExpr Postgres QBaseScope) -> QExpr Postgres QBaseScope Bool) -> Connection -> IO (Either SomeException [t Identity])-} -genericSelect table maybeFilter = +genericSelectList table maybeFilter = let pool = case maybeFilter of Nothing -> allElementsOfTable table Just f -> filter_ f $ allElementsOfTable table @@ -76,6 +77,16 @@ genericSelect table maybeFilter = $ runSelectReturningList $ select pool +-- |A generic select for a single element with filters +genericSelectOne table f = + \conn -> + try + $ runBeam conn + $ runSelectReturningOne + $ select + $ filter_ f + $ allElementsOfTable table + -- |Prepares a code to be used as key prepareCode :: String -> Text prepareCode = toUpper . pack @@ -87,22 +98,22 @@ prepareName = toTitle . pack -- people queries -- |Select all people in the database selectAllPeople :: Connection -> IO (Either SqlError [Person]) -selectAllPeople = genericSelect _persone Nothing +selectAllPeople = genericSelectList _persone Nothing -- |Select all laser cutter operators in the database selectAllLaserCutterOperators :: Connection -> IO (Either SqlError [Person]) selectAllLaserCutterOperators = - genericSelect _persone $ Just (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) + genericSelectList _persone $ Just (\p -> _personOperatoreIntagliatrice p ==. (val_ True)) -- |Select all 3D printer operators in the database selectAllPrinterOperators :: Connection -> IO (Either SqlError [Person]) selectAllPrinterOperators = - genericSelect _persone $ Just (\p -> _personOperatoreStampante p ==. (val_ True)) + genericSelectList _persone $ Just (\p -> _personOperatoreStampante p ==. (val_ True)) -- |Select all people with the given cf (should be 0 or 1) in the database -selectPersonFromCF :: String -> (Connection -> IO (Either SqlError [Person])) +selectPersonFromCF :: String -> (Connection -> IO (Either SqlError (Maybe Person))) selectPersonFromCF cf = - genericSelect _persone $ Just (\p -> _personCf p ==. (val_ (pack cf))) + genericSelectOne _persone (\p -> _personCf p ==. (val_ (pack cf))) -- |Add a person to the database insertPerson :: String -> String -> String -> (Connection -> IO (Either SqlError ())) @@ -143,21 +154,21 @@ modifyPerson cf partner cutter printer = -- materials queries -- |Select all materials in the database selectAllMaterials :: Connection -> IO (Either SqlError [Material]) -selectAllMaterials = genericSelect _materiali Nothing +selectAllMaterials = genericSelectList _materiali Nothing -- |Select all classes of materials in the database selectAllMaterialsClasses :: Connection -> IO (Either SqlError [MaterialsClass]) -selectAllMaterialsClasses = genericSelect _classi_di_materiali Nothing +selectAllMaterialsClasses = genericSelectList _classi_di_materiali Nothing -- |Select all the materials classes with the given code (should be 1 or 0) in the database -selectMaterialsClassFromCode :: String -> (Connection -> IO (Either SqlError [MaterialsClass])) +selectMaterialsClassFromCode :: String -> (Connection -> IO (Either SqlError (Maybe MaterialsClass))) selectMaterialsClassFromCode code = - genericSelect _classi_di_materiali $ Just (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) + genericSelectOne _classi_di_materiali (\c -> _materialsclassCodiceClasse c ==. (val_ (prepareCode code))) -- |Select all materials with the given code (should be 1 or 0) in the database -selectMaterialFromCode :: String -> (Connection -> IO (Either SqlError [Material])) +selectMaterialFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Material))) selectMaterialFromCode code = - genericSelect _materiali $ Just (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) + genericSelectOne _materiali (\m -> _materialCodiceMateriale m ==. (val_ (prepareCode code))) -- |Select all materials of a given class in the database selectMaterialsByClass :: String -> (Connection -> IO (Either SqlError [Material])) @@ -165,14 +176,14 @@ selectMaterialsByClass classCode = \conn -> do selectedClasses <- (selectMaterialsClassFromCode classCode) conn case selectedClasses of - Left ex -> pure $ Left ex - Right classes -> - let mClass = Prelude.head classes - in try $ runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) - $ allElementsOfTable _materiali + Left ex -> return $ Left ex + Right Nothing -> return $ Right [] + Right (Just mClass) -> + try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\m -> _materialCodiceClasse m ==. val_ (pk mClass)) + $ allElementsOfTable _materiali -- |Add a class of materials to the database in the database insertMaterialsClass :: String -> String -> (Connection -> IO (Either SqlError ())) @@ -194,39 +205,39 @@ insertMaterial code classCode name width descr = \conn -> do selectedClasses <- (selectMaterialsClassFromCode classCode) conn case selectedClasses of - Left ex -> pure $ Left ex - Right classes -> - let mClass = Prelude.head classes - in try $ runBeam conn - $ runInsert - $ insert (_materiali fabLabDB) - $ insertValues - [ Material - (pk mClass) - (prepareCode (classCode ++ code)) - (prepareName name) - width - (pack descr) - ] + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No class with the given code was present" "" "" + Right (Just mClass) -> + try $ runBeam conn + $ runInsert + $ insert (_materiali fabLabDB) + $ insertValues + [ Material + (pk mClass) + (prepareCode (classCode ++ code)) + (prepareName name) + width + (pack descr) + ] -- processings queries -- |Select the processing with the given code in the database -selectProcessingFromCode :: String -> (Connection -> IO (Either SqlError [Processing])) +selectProcessingFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Processing))) selectProcessingFromCode pCode = - genericSelect _lavorazioni $ Just (\p -> _processingCodiceLavorazione p ==. val_ (prepareCode pCode)) + genericSelectOne _lavorazioni (\p -> _processingCodiceLavorazione p ==. val_ (prepareCode pCode)) -- |Select all processings in the database selectAllProcessings :: Connection -> IO (Either SqlError [Processing]) -selectAllProcessings = genericSelect _lavorazioni Nothing +selectAllProcessings = genericSelectList _lavorazioni Nothing -- |Select all types of processing in the database selectAllTypes :: Connection -> IO (Either SqlError [Type]) -selectAllTypes = genericSelect _tipi Nothing +selectAllTypes = genericSelectList _tipi Nothing -- |Select all types of processing with the given code (should be 1 or 0) in the database -selectTypeFromCode :: String -> (Connection -> IO (Either SqlError [Type])) +selectTypeFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Type))) selectTypeFromCode code = - genericSelect _tipi $ Just (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) + genericSelectOne _tipi (\t -> _typeCodiceTipo t ==. (val_ (prepareCode code))) -- |Select all processings on a given material in the database selectProcessingsByMaterials :: String -> (Connection -> IO (Either SqlError [Processing])) @@ -234,14 +245,14 @@ selectProcessingsByMaterials mCode = \conn -> do selectedMaterials <- (selectMaterialFromCode mCode) conn case selectedMaterials of - Left ex -> pure $ Left ex - Right materials -> - let material = Prelude.head materials - in try $ runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) - $ allElementsOfTable _lavorazioni + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No material with the given code was present" "" "" + Right (Just material) -> + try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\p -> _processingCodiceMateriale p ==. val_ (pk material)) + $ allElementsOfTable _lavorazioni -- |Add a type of processing to the database insertType :: String -> String -> String -> (Connection -> IO (Either SqlError ())) @@ -265,13 +276,13 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = selectedTypes <- (selectTypeFromCode typeCode) conn selectedMaterials <- (selectMaterialFromCode materialCode) conn case (selectedTypes, selectedMaterials) of - (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) - (Left ex, _) -> pure $ Left ex - (_, Left ex) -> pure $ Left ex - (Right types, Right materials) -> - let pType = Prelude.head types :: Type - material = Prelude.head materials :: Material - code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode + (Left ex, Left ex') -> return $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> return $ Left ex + (_, Left ex) -> return $ Left ex + (Right Nothing, _) -> return $ Left $ SqlError "" NonfatalError "No type with the given code was present" "" "" + (_, Right Nothing) -> return $ Left $ SqlError "" NonfatalError "No material with the given code was present" "" "" + (Right (Just pType), Right (Just material)) -> + let code = materialCode ++ (show maxPotency) ++ (show minPotency) ++ (show speed) ++ typeCode in try $ runBeam conn $ runInsert $ insert (_lavorazioni fabLabDB) @@ -289,21 +300,21 @@ insertProcessing typeCode materialCode maxPotency minPotency speed descr = -- plastics and filaments queries -- |Select all filaments in the database selectAllFilaments :: Connection -> IO (Either SqlError [Filament]) -selectAllFilaments = genericSelect _filamenti Nothing +selectAllFilaments = genericSelectList _filamenti Nothing -- |Select all plastics in the database selectAllPlastics :: Connection -> IO (Either SqlError [Plastic]) -selectAllPlastics = genericSelect _plastiche Nothing +selectAllPlastics = genericSelectList _plastiche Nothing -- |Select all the plastics with the given code (should be 1 or 0) in the database -selectPlasticFromCode :: String -> (Connection -> IO (Either SqlError [Plastic])) +selectPlasticFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Plastic))) selectPlasticFromCode code = - genericSelect _plastiche $ Just (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) + genericSelectOne _plastiche (\p -> _plasticCodicePlastica p ==. (val_ (prepareCode code))) -- |Select all the filaments with the given code (should be 1 or 0) in the database -selectFilamentFromCode :: String -> (Connection -> IO (Either SqlError [Filament])) +selectFilamentFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Filament))) selectFilamentFromCode code = - genericSelect _filamenti $ Just (\f -> _filamentCodiceFilamento f ==. (val_ (prepareCode code))) + genericSelectOne _filamenti (\f -> _filamentCodiceFilamento f ==. (val_ (prepareCode code))) -- |Select the filaments made of a given plastic in the database selectFilamentsByPlastic :: String -> (Connection -> IO (Either SqlError [Filament])) @@ -311,14 +322,14 @@ selectFilamentsByPlastic plasticCode = \conn -> do selectedPlastics <- (selectPlasticFromCode plasticCode) conn case selectedPlastics of - Left ex -> pure $ Left ex - Right plastics -> - let plastic = Prelude.head plastics :: Plastic - in try $ runBeam conn - $ runSelectReturningList - $ select - $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) - $ allElementsOfTable _filamenti + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No plastic with the given code was present" "" "" + Right (Just plastic) -> + try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\f -> _filamentCodicePlastica f ==. val_ (pk plastic)) + $ allElementsOfTable _filamenti -- |Add a type of plastic to the database insertPlastic :: String -> String -> String -> (Connection -> IO (Either SqlError ())) @@ -341,29 +352,29 @@ insertFilament code plasticCode brand color = \conn -> do selectedPlastics <- (selectPlasticFromCode plasticCode) conn case selectedPlastics of - Left ex -> pure $ Left ex - Right plastics -> - let plastic = Prelude.head plastics - in try $ runBeam conn - $ runInsert - $ insert (_filamenti fabLabDB) - $ insertValues - [ Filament - (prepareCode code) - (pk plastic) - (prepareName brand) - (prepareName color) - ] + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No class with the given code was present" "" "" + Right (Just plastic) -> + try $ runBeam conn + $ runInsert + $ insert (_filamenti fabLabDB) + $ insertValues + [ Filament + (prepareCode code) + (pk plastic) + (prepareName brand) + (prepareName color) + ] -- printers queries -- |Select all printers in the database selectAllPrinters :: Connection -> IO (Either SqlError [Printer]) -selectAllPrinters = genericSelect _stampanti Nothing +selectAllPrinters = genericSelectList _stampanti Nothing -- |Select all the printers with the given code (should be 0 or 1) in the database -selectPrinterFromCode :: String -> (Connection -> IO (Either SqlError [Printer])) +selectPrinterFromCode :: String -> (Connection -> IO (Either SqlError (Maybe Printer))) selectPrinterFromCode code = - genericSelect _stampanti $ Just (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) + genericSelectOne _stampanti (\p -> _printerCodiceStampante p ==. (val_ (prepareCode code))) -- |Add a printer to the database insertPrinter :: String -> String -> String -> String -> (Connection -> IO (Either SqlError ())) @@ -387,34 +398,34 @@ assignPrinter printerCode printCode = \conn -> do selectedPrinters <- (selectPrinterFromCode printerCode) conn case selectedPrinters of - Left ex -> pure $ Left ex - Right printers -> - let printer = Prelude.head printers - in try $ runBeam conn - $ runUpdate - $ update (_stampe fabLabDB) - (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) - (\s -> _printCodiceStampa s ==. (val_ printCode)) + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No printer with the given code was present" "" "" + Right (Just printer) -> + try $ runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCodiceStampante s <-. just_ (val_ (pk printer))) + (\s -> _printCodiceStampa s ==. (val_ printCode)) -- prints queries -- |Select the print with the given code in the database (should be 0 or 1) -selectPrintFromCode :: Int -> (Connection -> IO (Either SqlError [Print])) +selectPrintFromCode :: Int -> (Connection -> IO (Either SqlError (Maybe Print))) selectPrintFromCode pCode = - genericSelect _stampe $ Just (\p -> _printCodiceStampa p ==. val_ pCode) + genericSelectOne _stampe (\p -> _printCodiceStampa p ==. val_ pCode) -- |Select all prints in the database selectAllPrints :: Connection -> IO (Either SqlError [Print]) -selectAllPrints = genericSelect _stampe Nothing +selectAllPrints = genericSelectList _stampe Nothing -- |Select all the print that aren't completed in the database selectAllIncompletePrints :: Connection -> IO (Either SqlError [Print]) selectAllIncompletePrints = - genericSelect _stampe $ Just (\p -> _printDataConsegna p ==. val_ Nothing) + genericSelectList _stampe $ Just (\p -> _printDataConsegna p ==. val_ Nothing) -- |Select all the completed prints in the database selectAllCompletePrints :: Connection -> IO (Either SqlError [Print]) selectAllCompletePrints = - genericSelect _stampe $ Just (\p -> _printDataConsegna p /=. val_ Nothing) + genericSelectList _stampe $ Just (\p -> _printDataConsegna p /=. val_ Nothing) -- |Add a new print to the database insertPrint :: String -> Day -> String -> (Connection -> IO (Either SqlError ())) @@ -422,26 +433,26 @@ insertPrint cf insertDate descr = \conn -> do selectedPeople <- (selectPersonFromCF cf) conn case selectedPeople of - Left ex -> pure $ Left ex - Right people -> - let person = Prelude.head people - in try $ runBeam conn - $ runInsert - $ insert (_stampe fabLabDB) - $ insertExpressions - [ Print - { _printCodiceStampa = default_, - _printDataRichiesta = val_ insertDate, - _printDataConsegna = val_ Nothing, - _printTempo = val_ Nothing, - _printCostoMateriali = val_ Nothing, - _printCostoTotale = val_ Nothing, - _printDescrizione = val_ (pack descr), - _printCfRichiedente = val_ (pk person), - _printCfIncaricato = nothing_, - _printCodiceStampante = nothing_ - } - ] + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No person with the given code was present" "" "" + Right (Just person) -> + try $ runBeam conn + $ runInsert + $ insert (_stampe fabLabDB) + $ insertExpressions + [ Print + { _printCodiceStampa = default_, + _printDataRichiesta = val_ insertDate, + _printDataConsegna = val_ Nothing, + _printTempo = val_ Nothing, + _printCostoMateriali = val_ Nothing, + _printCostoTotale = val_ Nothing, + _printDescrizione = val_ (pack descr), + _printCfRichiedente = val_ (pk person), + _printCfIncaricato = nothing_, + _printCodiceStampante = nothing_ + } + ] -- |Assign a print to an operator assignPrint :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -449,14 +460,14 @@ assignPrint code cf = \conn -> do selectedOperators <- (selectPersonFromCF cf) conn case selectedOperators of - Left ex -> pure $ Left ex - Right operators -> - let operator = Prelude.head operators - in try $ runBeam conn - $ runUpdate - $ update (_stampe fabLabDB) - (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) - (\s -> _printCodiceStampa s ==. val_ code) + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No person with the given code was present" "" "" + Right (Just operator) -> + try $ runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + (\s -> _printCfIncaricato s <-. just_ (val_ (pk operator))) + (\s -> _printCodiceStampa s ==. val_ code) -- |Assign a filament to a print in the database assignFilament :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -465,21 +476,21 @@ assignFilament pCode fCode = selectedFilaments <- (selectFilamentFromCode fCode) conn selectedPrints <- (selectPrintFromCode pCode) conn case (selectedFilaments, selectedPrints) of - (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) - (Left ex, _) -> pure $ Left ex - (_, Left ex) -> pure $ Left ex - (Right filaments, Right prints) -> - let filament = Prelude.head filaments - selectedPrint = Prelude.head prints - in try $ runBeam conn - $ runInsert - $ insert (_usi fabLabDB) - $ insertExpressions - [ Use - { _useCodiceFilamento = val_ (pk filament), - _useCodiceStampa = val_ (pk selectedPrint) - } - ] + (Left ex, Left ex') -> return $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> return $ Left ex + (_, Left ex) -> return $ Left ex + (Right Nothing, _) -> return $ Left $ SqlError "" NonfatalError "No filament with the given code was present" "" "" + (_, Right Nothing) -> return $ Left $ SqlError "" NonfatalError "No print with the given code was present" "" "" + (Right (Just filament), Right (Just selectedPrint)) -> + try $ runBeam conn + $ runInsert + $ insert (_usi fabLabDB) + $ insertExpressions + [ Use + { _useCodiceFilamento = val_ (pk filament), + _useCodiceStampa = val_ (pk selectedPrint) + } + ] -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) @@ -501,23 +512,23 @@ completePrint pCode deliveryDate workTime total materials = -- cuts queries -- |Select the cut with the given code in the database (should be 0 or 1) -selectCutFromCode :: Int -> (Connection -> IO (Either SqlError [Cut])) +selectCutFromCode :: Int -> (Connection -> IO (Either SqlError (Maybe Cut))) selectCutFromCode cCode = - genericSelect _intagli $ Just (\c -> _cutCodiceIntaglio c ==. val_ cCode) + genericSelectOne _intagli (\c -> _cutCodiceIntaglio c ==. val_ cCode) -- |Select all cuts in the database selectAllCuts :: Connection -> IO (Either SqlError [Cut]) -selectAllCuts = genericSelect _intagli Nothing +selectAllCuts = genericSelectList _intagli Nothing -- |Select all the print that aren't completed in the database selectAllIncompleteCuts :: Connection -> IO (Either SqlError [Cut]) selectAllIncompleteCuts = - genericSelect _intagli $ Just (\c -> _cutDataConsegna c ==. val_ Nothing) + genericSelectList _intagli $ Just (\c -> _cutDataConsegna c ==. val_ Nothing) -- |Select all the completed prints in the database selectAllCompleteCuts :: Connection -> IO (Either SqlError [Cut]) selectAllCompleteCuts = - genericSelect _intagli $ Just (\c -> _cutDataConsegna c /=. val_ Nothing) + genericSelectList _intagli $ Just (\c -> _cutDataConsegna c /=. val_ Nothing) -- |Add a new cut to the database insertCut :: String -> Day -> String -> (Connection -> IO (Either SqlError ())) @@ -525,25 +536,25 @@ insertCut cf insertDate descr = \conn -> do selectedPeople <- selectPersonFromCF cf conn case selectedPeople of - Left ex -> pure $ Left ex - Right people -> - let person = Prelude.head people - in try $ runBeam conn - $ runInsert - $ insert (_intagli fabLabDB) - $ insertExpressions - [ Cut - { _cutCodiceIntaglio = default_, - _cutDataRichiesta = val_ insertDate, - _cutDataConsegna = val_ Nothing, - _cutTempo = val_ Nothing, - _cutCostoMateriali = val_ Nothing, - _cutCostoTotale = val_ Nothing, - _cutDescrizione = val_ (pack descr), - _cutCfRichiedente = val_ (pk person), - _cutCfIncaricato = nothing_ - } - ] + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No person with the given code was present" "" "" + Right (Just person) -> + try $ runBeam conn + $ runInsert + $ insert (_intagli fabLabDB) + $ insertExpressions + [ Cut + { _cutCodiceIntaglio = default_, + _cutDataRichiesta = val_ insertDate, + _cutDataConsegna = val_ Nothing, + _cutTempo = val_ Nothing, + _cutCostoMateriali = val_ Nothing, + _cutCostoTotale = val_ Nothing, + _cutDescrizione = val_ (pack descr), + _cutCfRichiedente = val_ (pk person), + _cutCfIncaricato = nothing_ + } + ] -- |Assign a cut to an operator assignCut :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -551,14 +562,14 @@ assignCut code cf = \conn -> do selectedOperators <- (selectPersonFromCF cf) conn case selectedOperators of - Left ex -> pure $ Left ex - Right operators -> - let operator = Prelude.head operators - in try $ runBeam conn - $ runUpdate - $ update (_intagli fabLabDB) - (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) - (\c -> _cutCodiceIntaglio c ==. val_ code) + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No person with the given code was present" "" "" + Right (Just operator) -> + try $ runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + (\c -> _cutCfIncaricato c <-. just_ (val_ (pk operator))) + (\c -> _cutCodiceIntaglio c ==. val_ code) -- |Assign a processing to a print assignProcessing :: Int -> String -> (Connection -> IO (Either SqlError ())) @@ -567,21 +578,21 @@ assignProcessing cCode pCode = selectedProcessings <- (selectProcessingFromCode pCode) conn selectedCuts <- (selectCutFromCode cCode) conn case (selectedProcessings, selectedCuts) of - (Left ex, Left ex') -> pure $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) - (Left ex, _) -> pure $ Left ex - (_, Left ex) -> pure $ Left ex - (Right processings, Right cuts) -> do - let processing = Prelude.head processings - cut = Prelude.head cuts - in try $ runBeam conn - $ runInsert - $ insert (_composizioni fabLabDB) - $ insertExpressions - [ Composition - { _compositionCodiceLavorazione = val_ (pk processing), - _compositionCodiceIntaglio = val_ (pk cut) - } - ] + (Left ex, Left ex') -> return $ Left $ (error $ (toString $ sqlErrorMsg ex) ++ (toString $ sqlErrorMsg ex')) + (Left ex, _) -> return $ Left ex + (_, Left ex) -> return $ Left ex + (Right Nothing, _) -> return $ Left $ SqlError "" NonfatalError "No processing with the given code was present" "" "" + (_, Right Nothing) -> return $ Left $ SqlError "" NonfatalError "No cut with the given code was present" "" "" + (Right (Just processing), Right (Just cut)) -> do + try $ runBeam conn + $ runInsert + $ insert (_composizioni fabLabDB) + $ insertExpressions + [ Composition + { _compositionCodiceLavorazione = val_ (pk processing), + _compositionCodiceIntaglio = val_ (pk cut) + } + ] -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) From 81c4fb0b322ed29d367dbb5dd9328dd90251bbde Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 19 Sep 2019 11:54:32 +0200 Subject: [PATCH 18/73] Implement Users module for users management --- package.yaml | 2 +- src/Users.hs | 220 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 221 insertions(+), 1 deletion(-) create mode 100644 src/Users.hs diff --git a/package.yaml b/package.yaml index b63eee0..3080a3c 100644 --- a/package.yaml +++ b/package.yaml @@ -26,6 +26,7 @@ dependencies: - beam-postgres - bytestring - configurator +- cryptonite - hvect - mtl - postgresql-libpq @@ -33,7 +34,6 @@ dependencies: - Spock >= 0.11 - text - time -- transformers - utf8-string - wai-middleware-static diff --git a/src/Users.hs b/src/Users.hs new file mode 100644 index 0000000..0b4fc6a --- /dev/null +++ b/src/Users.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- |Module used for managing users of the application +module Users where + +import Control.Exception +import Data.Int (Int) +import Data.Text +import Data.Time +import Database.Beam +import Database.Beam.Backend.SQL (BeamSqlBackend) +import Database.Beam.Postgres +import Database.PostgreSQL.LibPQ (ExecStatus (NonfatalError)) + +-- datatypes +-- |A session id +type SessionID = Int + +-- |The result of a login +data CheckUserResult + = AllOk + | WrongUsername + | WrongPassword + deriving (Eq, Show) + +-- |Data representing an admin +data AdminT f + = Admin + { _adminUsername :: Columnar f Text, + _adminHash :: Columnar f Text + } + deriving (Beamable, Generic) + +instance Table AdminT where + + data PrimaryKey AdminT f = AdminId (Columnar f Text) deriving (Beamable, Generic) + + primaryKey = AdminId . _adminUsername + +type Admin = AdminT Identity + +type AdminId = PrimaryKey AdminT Identity + +deriving instance Eq Admin + +deriving instance Show Admin + +deriving instance Eq AdminId + +deriving instance Show AdminId + +-- |Data representing a session +data SessionT f + = Session + { _sessionIdSessione :: Columnar f SessionID, + _sessionOraCreazione :: Columnar f UTCTime, + _sessionAdmin :: PrimaryKey AdminT f + } + deriving (Beamable, Generic) + +instance Table SessionT where + + data PrimaryKey SessionT f = SessionId (Columnar f SessionID) deriving (Beamable, Generic) + + primaryKey = SessionId . _sessionIdSessione + +type Session = SessionT Identity + +type SessionId = PrimaryKey SessionT Identity + +deriving instance Eq Session + +deriving instance Show Session + +deriving instance Eq SessionId + +deriving instance Show SessionId + +-- |Data representing the database +data AdminDB f + = AdminDB + { _admins :: f (TableEntity AdminT), + _sessioni :: f (TableEntity SessionT) + } + deriving (Database be, Generic) + +adminDb :: DatabaseSettings be AdminDB +adminDb = + withDbModification defaultDbSettings + dbModification + { _sessioni = + modifyTableFields + tableModification + { _sessionAdmin = AdminId (fieldNamed "admin") + } + } + +-- functions +-- |Connects to the database with the given characteristics +connectWithInfo + :: String -- ^ name of the host + -> Integer -- ^ port + -> String -- ^ username + -> String -- ^ password + -> String -- ^ name of the database + -> IO Connection +connectWithInfo host port user pswd db = connect $ ConnectInfo host (fromInteger port) user pswd db + +-- |Given a connection, close it +closeConnection :: Connection -> IO () +closeConnection = close + +runBeam :: Connection -> Pg a -> IO a +runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production purposes + +-- admins functions +-- | Insert a new admin into the database +insertAdmin :: String -> String -> (Connection -> IO (Either SqlError ())) +insertAdmin name hash = + \conn -> + try + $ runBeam conn + $ runInsert + $ insert (_admins adminDb) + $ insertValues + [ Admin + (pack name) + (pack hash) + ] + +-- |Select the admins with the given username +selectAdminFromUsername :: String -> (Connection -> IO (Either SqlError (Maybe Admin))) +selectAdminFromUsername name = + \conn -> + try + $ runBeam conn + $ runSelectReturningOne + $ select + $ filter_ (\n -> _adminUsername n ==. (val_ (pack name))) + $ all_ (_admins adminDb) + +-- |Checks if a user is in the database, with the correct hash +checkUser :: String -> String -> (Connection -> IO (Either SqlError CheckUserResult)) +checkUser user hash = + \conn -> do + mAdmin <- selectAdminFromUsername user conn + case mAdmin of + Left ex -> return $ Left ex + Right Nothing -> return $ Right WrongUsername + Right (Just admin) -> return $ Right $ if (pack hash) == (_adminHash admin) then AllOk else WrongPassword + +-- sessions functions +-- | Insert a new admin into the database +insertSession :: String -> UTCTime -> (Connection -> IO (Either SqlError ())) +insertSession name time = + \conn -> do + selectedAdmins <- selectAdminFromUsername name conn + case selectedAdmins of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No admin with the given username was present" "" "" + Right (Just admin) -> + try + $ runBeam conn + $ runInsert + $ insert (_sessioni adminDb) + $ insertExpressions + [ Session + { _sessionIdSessione = default_, + _sessionOraCreazione = val_ time, + _sessionAdmin = val_ $ pk admin + } + ] + +-- |Select the admins with the given username +selectSessionFromId :: SessionID -> (Connection -> IO (Either SqlError (Maybe Session))) +selectSessionFromId sId = + \conn -> + try + $ runBeam conn + $ runSelectReturningOne + $ select + $ filter_ (\s -> _sessionIdSessione s ==. (val_ $ sId)) + $ all_ + $ _sessioni adminDb + +-- |Select most recent session for a given admin +selectMostRecentSession :: String -> (Connection -> IO (Either SqlError (Maybe Session))) +selectMostRecentSession user = + \conn -> do + mAdmin <- selectAdminFromUsername user conn + case mAdmin of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No admin with the given username was present" "" "" + Right (Just admin) -> + try + $ runBeam conn + $ runSelectReturningOne + $ select + $ limit_ 1 + $ orderBy_ (desc_ . _sessionOraCreazione) + $ filter_ (\s -> _sessionAdmin s ==. (val_ $ pk admin)) + $ all_ + $ _sessioni adminDb + +-- |Check if the session is still valid +checkSessionValidity :: Session -> IO Bool +checkSessionValidity session = do + time <- getCurrentTime + return $ diffUTCTime time (_sessionOraCreazione session) < (3600 * 2) From 899501cf94af1a1446ed7182450f9005cfefa463 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 19 Sep 2019 12:27:13 +0200 Subject: [PATCH 19/73] Add encryption to passwords before saving, add basic client files --- client/index.css | 31 +++++++++++++ client/index.html | 33 ++++++++++++++ client/index.js | 34 ++++++++++++++ client/login.html | 18 ++++++++ package.yaml | 1 + src/Server.hs | 114 +++++++++++++++++++++++++++++++++------------- src/Users.hs | 25 ++++++---- 7 files changed, 214 insertions(+), 42 deletions(-) create mode 100644 client/index.css create mode 100644 client/index.html create mode 100644 client/index.js create mode 100644 client/login.html diff --git a/client/index.css b/client/index.css new file mode 100644 index 0000000..1a3efcc --- /dev/null +++ b/client/index.css @@ -0,0 +1,31 @@ +.dropbtn { + background-color: black; + color: white; + padding: 16px; + font-size: 16px; + border: none; +} + +.menu { + position: relative; + display: inline-block; +} + +.dropdown-content { + display: none; + position: absolute; + background-color: lightgrey; + min-width: 200px; + z-index: 1; +} + +.dropdown-content a { + color: black; + padding: 12px 16px; + text-decoration: none; + display: block; +} + +.dropdown-content a:hover {background-color: white;} +.menu:hover .dropdown-content {display: block;} +.menu:hover .dropbtn {background-color: grey;} diff --git a/client/index.html b/client/index.html new file mode 100644 index 0000000..1b77d95 --- /dev/null +++ b/client/index.html @@ -0,0 +1,33 @@ + + + + + + + Menù + + + +
+ +
+ Anagrafiche + Stampe + Intagli + Materiali + Plastiche +
+
+
+
+ +
+
+
+ +
+ + + \ No newline at end of file diff --git a/client/index.js b/client/index.js new file mode 100644 index 0000000..11ff445 --- /dev/null +++ b/client/index.js @@ -0,0 +1,34 @@ +base_url = 'http://localhost:8080/' + +function set_json_data(url, selectId, setter) { + var html_code = ''; + var xhr = new XMLHttpRequest(); + xhr.onreadystatechange = function() { + if (xhr.readyState == 4 && xhr.status == 200) + setter(selectId, JSON.parse(xhr.responseText)); + } + xhr.open('GET', url, true); + xhr.send(); +} + +function set_select_list(selectId, options) { + var selectElement = document.getElementById(selectId); + while (selectElement.options.length) { + selectElement.remove(0); + } + for (var i = 0; i < options.length; i++) { + var opt = options[i]; + var str = opt._personNome.concat(" ", opt._personCognome, " ", opt._personCf); + selectElement.options.add(new Option(str, i)); + } +} + +function set_all_people(selectId) { + set_json_data(base_url.concat('people'), selectId, set_select_list); +} + +function initWindow() { + set_all_people('select_richiedenti'); +} + +window.onload = initWindow(); \ No newline at end of file diff --git a/client/login.html b/client/login.html new file mode 100644 index 0000000..84df9b6 --- /dev/null +++ b/client/login.html @@ -0,0 +1,18 @@ + + + + + Login + + + +
+ Username: +
+ Password: +
+ +
+ + + \ No newline at end of file diff --git a/package.yaml b/package.yaml index 3080a3c..10d0d46 100644 --- a/package.yaml +++ b/package.yaml @@ -28,6 +28,7 @@ dependencies: - configurator - cryptonite - hvect +- memory - mtl - postgresql-libpq - scientific diff --git a/src/Server.hs b/src/Server.hs index 6627144..f12f4d7 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -12,21 +12,22 @@ module Server where import Control.Exception -import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.Configurator as C import Data.HVect +import Data.List as L (groupBy) import Data.Text import Data.Text.Encoding +import Data.Time import Database.Beam import Database.Beam.Postgres (Connection, sqlErrorMsg) import GHC.Generics -import Query +import Network.Wai.Middleware.Static +import Query as Q import Schema +import Users as U import Web.Spock import Web.Spock.Config -import Web.Users.Postgresql -import Web.Users.Types (SessionId, User, UserStorageBackend, getUserById, verifySession) -- datatypes data IsGuest = IsGuest @@ -46,7 +47,7 @@ data ApiCfg -- app :: SpockM conn sess st () -- SpockM conn sess st = SpockCtxM () conn sess st -- SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) -type SessionVal = Maybe Web.Users.Types.SessionId +type SessionVal = Maybe SessionID type Api ctx = SpockCtxM ctx Connection SessionVal () () @@ -56,6 +57,9 @@ type ApiAction ctx a = SpockActionCtx ctx Connection SessionVal () a getClientFilePath :: String -> FilePath getClientFilePath fileName = "client/" ++ fileName +getFileName :: String -> String +getFileName partialUri = Prelude.last $ L.groupBy (\x y -> y /= '/') partialUri + -- |Parses the configuration file parseConfig :: FilePath -> IO ApiCfg parseConfig cfgFile = do @@ -70,12 +74,22 @@ parseConfig cfgFile = do return (ApiCfg db dbLocation dbPort dbUser dbPassword port name) -- |Function used to get the connection used to interrogate the database -getConnection :: String -> Integer -> String -> String -> String -> PoolOrConn Connection -getConnection host port user pswd name = +getFabLabConnection + :: String -- ^ Host name + -> Integer -- ^ Port + -> String -- ^ Username + -> String -- ^ Password + -> String -- ^ Name of the database + -> IO Connection +getFabLabConnection = Q.connectWithInfo + +-- |Function used to get the PoolOrConn necessary to interrogate the database +getPoolOrConn :: IO Connection -> PoolOrConn Connection +getPoolOrConn conn = PCConn $ ConnBuilder - (connectWithInfo host port user pswd name) - (closeConnection) + conn + (Q.closeConnection) (PoolCfg 1 12 1) -- |Produces an error with the given code and description @@ -90,59 +104,95 @@ errorJson code message = baseHook :: Monad m => ActionCtxT () m (HVect '[]) baseHook = return HNil -authHook :: UserStorageBackend conn0 => ActionCtxT (HVect ts1) (WebStateM conn0 SessionVal st) (HVect (User : ts1)) +authHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (Admin : ts1)) authHook = do oldCtx <- getContext sess <- readSession - mUser <- getUserFromSession - case mUser of - Nothing -> - text "Unknown user. Login first!" - Just val -> - return (val :&: oldCtx) - -getUserFromSession :: UserStorageBackend b0 => ActionCtxT ctx (WebStateM b0 SessionVal st) (Maybe User) -getUserFromSession = - runMaybeT $ do - sessId <- MaybeT readSession - uid <- MaybeT $ runQuery (\conn -> verifySession conn sessId 0) - user <- MaybeT $ runQuery (`getUserById` uid) - return user + mAdmin <- getAdminFromSession + case mAdmin of + Nothing -> redirect "" + Just val -> return (val :&: oldCtx) + +getAdminFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe Admin) +getAdminFromSession = + do + sessId <- readSession + case sessId of + Nothing -> return Nothing + Just sId -> do + queryResult <- runQuery $ selectSessionFromId $ sId + case queryResult of + Left ex -> return Nothing + Right Nothing -> return Nothing + Right (Just session) -> + let (AdminId id) = _sessionAdmin session + in do + queryResult' <- runQuery $ selectAdminFromUsername $ unpack id + case queryResult' of + Left ex -> return Nothing + Right a -> return a loginAction :: Text -> Text -> ApiAction ctx () -loginAction user pswd = undefined +loginAction user pswd = do + queryResult <- runQuery $ checkUser (unpack user) (unpack pswd) + case queryResult of + Left ex -> text "There was a problem during your authentication" + Right WrongUsername -> text "Wrong username" + Right WrongPassword -> text "Wrong password" + Right AllOk -> do + time <- liftIO getCurrentTime + insertResult <- runQuery $ insertSession (unpack user) time + case insertResult of + Right () -> do + mSession <- runQuery $ selectMostRecentSession $ unpack user + case mSession of + Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex + Right Nothing -> text "I seriously hope this text will never be displayed" + Right (Just session) -> + let sid = _sessionIdSessione session + in do + writeSession (Just sid) + redirect "app" + Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex -- server functions runServer :: ApiCfg -> IO () runServer cfg = - let conn = - getConnection (unpack $ acfg_db_location cfg) + let ioConn = + getFabLabConnection (unpack $ acfg_db_location cfg) (acfg_db_port cfg) (unpack $ acfg_db_user cfg) (unpack $ acfg_db_pswd cfg) (unpack $ acfg_db cfg) in do - spockCfg <- defaultSpockCfg Nothing conn () + spockCfg <- defaultSpockCfg Nothing (getPoolOrConn ioConn) () runSpock 8080 (spock spockCfg app) app :: Api () app = do + middleware $ staticPolicy $ addBase "static" prehook baseHook $ do get root $ do - file "login form" $ getClientFilePath "login.html" + file "text/html" $ getClientFilePath "login.html" post "login" $ do maybeUser <- param "username" maybePswd <- param "password" case (maybeUser, maybePswd) of (Just user, Just pswd) -> loginAction user pswd (_, _) -> errorJson 400 "Missing parameter" + get "index.js" $ + file "application/javascript" $ getClientFilePath "index.js" + get ("index.css") $ + file "text/css" $ getClientFilePath "index.css" prehook authHook $ do -- here goes requests for pages and data - get "materials" $ do - queryResult <- runQuery selectAllMaterials + get "people" $ do + queryResult <- runQuery selectAllPeople case queryResult of Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex - Right allMaterials -> json allMaterials + Right allPeople -> json allPeople + get "app" $ do + file "text/html" $ getClientFilePath "index.html" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person diff --git a/src/Users.hs b/src/Users.hs index 0b4fc6a..c0b0f05 100644 --- a/src/Users.hs +++ b/src/Users.hs @@ -15,8 +15,12 @@ module Users where import Control.Exception +import Crypto.KDF.BCrypt (hashPassword, validatePassword) +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 as BSU import Data.Int (Int) -import Data.Text +import Data.Text as T +import Data.Text.Encoding import Data.Time import Database.Beam import Database.Beam.Backend.SQL (BeamSqlBackend) @@ -38,7 +42,7 @@ data CheckUserResult data AdminT f = Admin { _adminUsername :: Columnar f Text, - _adminHash :: Columnar f Text + _adminHash :: Columnar f BS.ByteString } deriving (Beamable, Generic) @@ -127,16 +131,17 @@ runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production pur -- admins functions -- | Insert a new admin into the database insertAdmin :: String -> String -> (Connection -> IO (Either SqlError ())) -insertAdmin name hash = - \conn -> +insertAdmin name pswd = + \conn -> do + hash <- hashPassword 12 $ BSU.fromString pswd try $ runBeam conn $ runInsert $ insert (_admins adminDb) $ insertValues [ Admin - (pack name) - (pack hash) + (T.pack name) + hash ] -- |Select the admins with the given username @@ -147,18 +152,18 @@ selectAdminFromUsername name = $ runBeam conn $ runSelectReturningOne $ select - $ filter_ (\n -> _adminUsername n ==. (val_ (pack name))) + $ filter_ (\n -> _adminUsername n ==. (val_ (T.pack name))) $ all_ (_admins adminDb) --- |Checks if a user is in the database, with the correct hash +-- |Checks if a user is in the database, with the correct password checkUser :: String -> String -> (Connection -> IO (Either SqlError CheckUserResult)) -checkUser user hash = +checkUser user pswd = \conn -> do mAdmin <- selectAdminFromUsername user conn case mAdmin of Left ex -> return $ Left ex Right Nothing -> return $ Right WrongUsername - Right (Just admin) -> return $ Right $ if (pack hash) == (_adminHash admin) then AllOk else WrongPassword + Right (Just admin) -> return $ Right $ if validatePassword (BSU.fromString pswd) (_adminHash admin) then AllOk else WrongPassword -- sessions functions -- | Insert a new admin into the database From c4d72cca3fa2ee765998de7de31ef892b0220137 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 19 Sep 2019 20:19:46 +0200 Subject: [PATCH 20/73] Correct user and admin logic in Users module --- src/Server.hs | 22 +++++---- src/Users.hs | 128 ++++++++++++++++++++++++++++++-------------------- 2 files changed, 89 insertions(+), 61 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index f12f4d7..1f592ab 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -104,17 +104,17 @@ errorJson code message = baseHook :: Monad m => ActionCtxT () m (HVect '[]) baseHook = return HNil -authHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (Admin : ts1)) +authHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) authHook = do oldCtx <- getContext sess <- readSession - mAdmin <- getAdminFromSession - case mAdmin of + mUser <- getUserFromSession + case mUser of Nothing -> redirect "" Just val -> return (val :&: oldCtx) -getAdminFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe Admin) -getAdminFromSession = +getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) +getUserFromSession = do sessId <- readSession case sessId of @@ -125,9 +125,9 @@ getAdminFromSession = Left ex -> return Nothing Right Nothing -> return Nothing Right (Just session) -> - let (AdminId id) = _sessionAdmin session + let (UserId id) = _sessionUtente session in do - queryResult' <- runQuery $ selectAdminFromUsername $ unpack id + queryResult' <- runQuery $ selectUserFromUsername $ unpack id case queryResult' of Left ex -> return Nothing Right a -> return a @@ -184,15 +184,19 @@ app = do file "application/javascript" $ getClientFilePath "index.js" get ("index.css") $ file "text/css" $ getClientFilePath "index.css" + get "login.js" $ + file "application/javascript" $ getClientFilePath "login.js" + get ("login.css") $ + file "text/css" $ getClientFilePath "login.css" prehook authHook $ do -- here goes requests for pages and data + get "app" $ do + file "text/html" $ getClientFilePath "index.html" get "people" $ do queryResult <- runQuery selectAllPeople case queryResult of Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex Right allPeople -> json allPeople - get "app" $ do - file "text/html" $ getClientFilePath "index.html" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person diff --git a/src/Users.hs b/src/Users.hs index c0b0f05..1d08fb9 100644 --- a/src/Users.hs +++ b/src/Users.hs @@ -31,45 +31,53 @@ import Database.PostgreSQL.LibPQ (ExecStatus (NonfatalError)) -- |A session id type SessionID = Int --- |The result of a login +-- |The result of a user login data CheckUserResult = AllOk | WrongUsername | WrongPassword deriving (Eq, Show) --- |Data representing an admin -data AdminT f - = Admin - { _adminUsername :: Columnar f Text, - _adminHash :: Columnar f BS.ByteString +-- |The result of an admin login +data CheckAdminResult + = AdminOk + | WrongLogin + | NotAnAdmin + deriving (Eq, Show) + +-- |Data representing an user +data UserT f + = User + { _userUsername :: Columnar f Text, + _userHash :: Columnar f BS.ByteString, + _userAdmin :: Columnar f Bool } deriving (Beamable, Generic) -instance Table AdminT where +instance Table UserT where - data PrimaryKey AdminT f = AdminId (Columnar f Text) deriving (Beamable, Generic) + data PrimaryKey UserT f = UserId (Columnar f Text) deriving (Beamable, Generic) - primaryKey = AdminId . _adminUsername + primaryKey = UserId . _userUsername -type Admin = AdminT Identity +type User = UserT Identity -type AdminId = PrimaryKey AdminT Identity +type UserId = PrimaryKey UserT Identity -deriving instance Eq Admin +deriving instance Eq User -deriving instance Show Admin +deriving instance Show User -deriving instance Eq AdminId +deriving instance Eq UserId -deriving instance Show AdminId +deriving instance Show UserId -- |Data representing a session data SessionT f = Session { _sessionIdSessione :: Columnar f SessionID, _sessionOraCreazione :: Columnar f UTCTime, - _sessionAdmin :: PrimaryKey AdminT f + _sessionUtente :: PrimaryKey UserT f } deriving (Beamable, Generic) @@ -92,21 +100,21 @@ deriving instance Eq SessionId deriving instance Show SessionId -- |Data representing the database -data AdminDB f - = AdminDB - { _admins :: f (TableEntity AdminT), +data UserDB f + = UserDB + { _utenti :: f (TableEntity UserT), _sessioni :: f (TableEntity SessionT) } deriving (Database be, Generic) -adminDb :: DatabaseSettings be AdminDB -adminDb = +userDb :: DatabaseSettings be UserDB +userDb = withDbModification defaultDbSettings dbModification { _sessioni = modifyTableFields tableModification - { _sessionAdmin = AdminId (fieldNamed "admin") + { _sessionUtente = UserId (fieldNamed "user") } } @@ -128,66 +136,82 @@ closeConnection = close runBeam :: Connection -> Pg a -> IO a runBeam = runBeamPostgres --Debug putStrLn -- change for debug or production purposes --- admins functions --- | Insert a new admin into the database -insertAdmin :: String -> String -> (Connection -> IO (Either SqlError ())) -insertAdmin name pswd = +-- users functions +-- | Insert a new user into the database +insertUser :: String -> String -> (Connection -> IO (Either SqlError ())) +insertUser name pswd = \conn -> do hash <- hashPassword 12 $ BSU.fromString pswd try $ runBeam conn $ runInsert - $ insert (_admins adminDb) + $ insert (_utenti userDb) $ insertValues - [ Admin + [ User (T.pack name) hash + False ] --- |Select the admins with the given username -selectAdminFromUsername :: String -> (Connection -> IO (Either SqlError (Maybe Admin))) -selectAdminFromUsername name = +-- |Select the users with the given username +selectUserFromUsername :: String -> (Connection -> IO (Either SqlError (Maybe User))) +selectUserFromUsername name = \conn -> try $ runBeam conn $ runSelectReturningOne $ select - $ filter_ (\n -> _adminUsername n ==. (val_ (T.pack name))) - $ all_ (_admins adminDb) + $ filter_ (\n -> _userUsername n ==. (val_ (T.pack name))) + $ all_ (_utenti userDb) -- |Checks if a user is in the database, with the correct password checkUser :: String -> String -> (Connection -> IO (Either SqlError CheckUserResult)) checkUser user pswd = \conn -> do - mAdmin <- selectAdminFromUsername user conn - case mAdmin of + mUser <- selectUserFromUsername user conn + case mUser of Left ex -> return $ Left ex Right Nothing -> return $ Right WrongUsername - Right (Just admin) -> return $ Right $ if validatePassword (BSU.fromString pswd) (_adminHash admin) then AllOk else WrongPassword + Right (Just user) -> return $ Right $ if validatePassword (BSU.fromString pswd) (_userHash user) then AllOk else WrongPassword + +-- |Checks if a user is an admin in the database, with the correct password +checkAdmin :: String -> String -> (Connection -> IO (Either SqlError CheckAdminResult)) +checkAdmin user pswd = + \conn -> do + checkResult <- checkUser user pswd conn + case checkResult of + Left ex -> return $ Left ex + Right AllOk -> do + mUser <- selectUserFromUsername user conn + case mUser of + Left ex -> return $ Left ex + Right Nothing -> return $ Right WrongLogin + Right (Just user) -> return $ Right $ if _userAdmin user then AdminOk else NotAnAdmin + _ -> return $ Right $ WrongLogin -- sessions functions --- | Insert a new admin into the database +-- | Insert a new user into the database insertSession :: String -> UTCTime -> (Connection -> IO (Either SqlError ())) insertSession name time = \conn -> do - selectedAdmins <- selectAdminFromUsername name conn - case selectedAdmins of + selectedUsers <- selectUserFromUsername name conn + case selectedUsers of Left ex -> return $ Left ex - Right Nothing -> return $ Left $ SqlError "" NonfatalError "No admin with the given username was present" "" "" - Right (Just admin) -> + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No user with the given username was present" "" "" + Right (Just user) -> try $ runBeam conn $ runInsert - $ insert (_sessioni adminDb) + $ insert (_sessioni userDb) $ insertExpressions [ Session { _sessionIdSessione = default_, _sessionOraCreazione = val_ time, - _sessionAdmin = val_ $ pk admin + _sessionUtente = val_ $ pk user } ] --- |Select the admins with the given username +-- |Select the users with the given username selectSessionFromId :: SessionID -> (Connection -> IO (Either SqlError (Maybe Session))) selectSessionFromId sId = \conn -> @@ -197,26 +221,26 @@ selectSessionFromId sId = $ select $ filter_ (\s -> _sessionIdSessione s ==. (val_ $ sId)) $ all_ - $ _sessioni adminDb + $ _sessioni userDb --- |Select most recent session for a given admin +-- |Select most recent session for a given user selectMostRecentSession :: String -> (Connection -> IO (Either SqlError (Maybe Session))) selectMostRecentSession user = \conn -> do - mAdmin <- selectAdminFromUsername user conn - case mAdmin of + mUser <- selectUserFromUsername user conn + case mUser of Left ex -> return $ Left ex - Right Nothing -> return $ Left $ SqlError "" NonfatalError "No admin with the given username was present" "" "" - Right (Just admin) -> + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No user with the given username was present" "" "" + Right (Just user) -> try $ runBeam conn $ runSelectReturningOne $ select $ limit_ 1 $ orderBy_ (desc_ . _sessionOraCreazione) - $ filter_ (\s -> _sessionAdmin s ==. (val_ $ pk admin)) + $ filter_ (\s -> _sessionUtente s ==. (val_ $ pk user)) $ all_ - $ _sessioni adminDb + $ _sessioni userDb -- |Check if the session is still valid checkSessionValidity :: Session -> IO Bool From 28d47d43d7bcfc90895b98e8e0231829d39a1676 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 19 Sep 2019 20:31:57 +0200 Subject: [PATCH 21/73] Expanded server to support user and admin logic --- src/Server.hs | 26 +++++++++++++++++++++++++- src/Users.hs | 2 +- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 1f592ab..9aa8d94 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -113,6 +113,18 @@ authHook = do Nothing -> redirect "" Just val -> return (val :&: oldCtx) +adminHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) +adminHook = do + oldCtx <- getContext + sess <- readSession + mUser <- getUserFromSession + case mUser of + Nothing -> redirect "" + Just user -> + case _userAdmin user of + True -> return (user :&: oldCtx) + False -> redirect "" + getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) getUserFromSession = do @@ -197,7 +209,19 @@ app = do case queryResult of Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex Right allPeople -> json allPeople - + prehook adminHook $ do + get "manager" $ do + text "with great power comes great responsability!" + post "newUser" $ do + maybeUser <- param "username" + maybePswd <- param "password" + case (maybeUser, maybePswd) of + (Just user, Just pswd) -> do + queryResult <- runQuery $ insertUser user pswd + case queryResult of + Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex + Right () -> text "all went well" + (_, _) -> errorJson 400 "Missing parameter" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person diff --git a/src/Users.hs b/src/Users.hs index 1d08fb9..2717614 100644 --- a/src/Users.hs +++ b/src/Users.hs @@ -114,7 +114,7 @@ userDb = { _sessioni = modifyTableFields tableModification - { _sessionUtente = UserId (fieldNamed "user") + { _sessionUtente = UserId (fieldNamed "utente") } } From e55e282402f675d5e1067154fbce07da29a97bb3 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 20 Sep 2019 09:27:01 +0200 Subject: [PATCH 22/73] Fix errorJson type for use --- src/Server.hs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 9aa8d94..f6006e6 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -47,6 +47,7 @@ data ApiCfg -- app :: SpockM conn sess st () -- SpockM conn sess st = SpockCtxM () conn sess st -- SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st) +-- json :: (ToJSON a, MonadIO m) => a -> ActionT m () type SessionVal = Maybe SessionID type Api ctx = SpockCtxM ctx Connection SessionVal () () @@ -93,7 +94,7 @@ getPoolOrConn conn = (PoolCfg 1 12 1) -- |Produces an error with the given code and description -errorJson :: Int -> Text -> ApiAction ctx () +errorJson :: MonadIO m => Int -> Text -> ActionCtxT ctx m b errorJson code message = json $ object @@ -110,7 +111,7 @@ authHook = do sess <- readSession mUser <- getUserFromSession case mUser of - Nothing -> redirect "" + Nothing -> errorJson 401 "Utente non autorizzato" Just val -> return (val :&: oldCtx) adminHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) @@ -123,7 +124,7 @@ adminHook = do Just user -> case _userAdmin user of True -> return (user :&: oldCtx) - False -> redirect "" + False -> errorJson 401 "Admin non autorizzato" getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) getUserFromSession = @@ -184,6 +185,7 @@ app :: Api () app = do middleware $ staticPolicy $ addBase "static" prehook baseHook $ do + -- routes for unauthenticated users get root $ do file "text/html" $ getClientFilePath "login.html" post "login" $ do @@ -191,25 +193,26 @@ app = do maybePswd <- param "password" case (maybeUser, maybePswd) of (Just user, Just pswd) -> loginAction user pswd - (_, _) -> errorJson 400 "Missing parameter" - get "index.js" $ - file "application/javascript" $ getClientFilePath "index.js" - get ("index.css") $ - file "text/css" $ getClientFilePath "index.css" + (_, _) -> errorJson (400 :: Int) ("Missing parameter" :: Text) get "login.js" $ file "application/javascript" $ getClientFilePath "login.js" get ("login.css") $ file "text/css" $ getClientFilePath "login.css" prehook authHook $ do - -- here goes requests for pages and data + -- routes for authenticated users get "app" $ do file "text/html" $ getClientFilePath "index.html" get "people" $ do queryResult <- runQuery selectAllPeople case queryResult of - Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex + Left ex -> errorJson (400 :: Int) $ decodeUtf8 $ sqlErrorMsg ex Right allPeople -> json allPeople + get "index.js" $ + file "application/javascript" $ getClientFilePath "index.js" + get ("index.css") $ + file "text/css" $ getClientFilePath "index.css" prehook adminHook $ do + -- routes for authenticated admins get "manager" $ do text "with great power comes great responsability!" post "newUser" $ do @@ -219,9 +222,9 @@ app = do (Just user, Just pswd) -> do queryResult <- runQuery $ insertUser user pswd case queryResult of - Left ex -> errorJson 400 $ decodeUtf8 $ sqlErrorMsg ex + Left ex -> errorJson (400 :: Int) $ decodeUtf8 $ sqlErrorMsg ex Right () -> text "all went well" - (_, _) -> errorJson 400 "Missing parameter" + (_, _) -> errorJson (400 :: Int) ("Missing parameter" :: Text) -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person From 793f234d38ff0aea7628708ab126f91e590745ee Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 20 Sep 2019 09:37:34 +0200 Subject: [PATCH 23/73] Extend use of json messages --- src/Server.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index f6006e6..b649cba 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -94,8 +94,8 @@ getPoolOrConn conn = (PoolCfg 1 12 1) -- |Produces an error with the given code and description -errorJson :: MonadIO m => Int -> Text -> ActionCtxT ctx m b -errorJson code message = +messageJson :: MonadIO m => Int -> Text -> ActionCtxT ctx m b +messageJson code message = json $ object [ "result" .= String "failure", @@ -111,7 +111,7 @@ authHook = do sess <- readSession mUser <- getUserFromSession case mUser of - Nothing -> errorJson 401 "Utente non autorizzato" + Nothing -> messageJson 401 "Utente non autorizzato" Just val -> return (val :&: oldCtx) adminHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) @@ -124,7 +124,7 @@ adminHook = do Just user -> case _userAdmin user of True -> return (user :&: oldCtx) - False -> errorJson 401 "Admin non autorizzato" + False -> messageJson 401 "Admin non autorizzato" getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) getUserFromSession = @@ -149,9 +149,9 @@ loginAction :: Text -> Text -> ApiAction ctx () loginAction user pswd = do queryResult <- runQuery $ checkUser (unpack user) (unpack pswd) case queryResult of - Left ex -> text "There was a problem during your authentication" - Right WrongUsername -> text "Wrong username" - Right WrongPassword -> text "Wrong password" + Left ex -> messageJson 500 "Problema durante l'autenticazione" + Right WrongUsername -> messageJson 401 "Username errata" + Right WrongPassword -> messageJson 401 "Password errata" Right AllOk -> do time <- liftIO getCurrentTime insertResult <- runQuery $ insertSession (unpack user) time @@ -160,13 +160,13 @@ loginAction user pswd = do mSession <- runQuery $ selectMostRecentSession $ unpack user case mSession of Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex - Right Nothing -> text "I seriously hope this text will never be displayed" + Right Nothing -> messageJson 666 "Spero seriamente che questo testo non sarà mai mostrato" Right (Just session) -> let sid = _sessionIdSessione session in do writeSession (Just sid) redirect "app" - Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex -- server functions runServer :: ApiCfg -> IO () @@ -193,7 +193,7 @@ app = do maybePswd <- param "password" case (maybeUser, maybePswd) of (Just user, Just pswd) -> loginAction user pswd - (_, _) -> errorJson (400 :: Int) ("Missing parameter" :: Text) + (_, _) -> messageJson 401 "Parametro mancante" get "login.js" $ file "application/javascript" $ getClientFilePath "login.js" get ("login.css") $ @@ -205,7 +205,7 @@ app = do get "people" $ do queryResult <- runQuery selectAllPeople case queryResult of - Left ex -> errorJson (400 :: Int) $ decodeUtf8 $ sqlErrorMsg ex + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex Right allPeople -> json allPeople get "index.js" $ file "application/javascript" $ getClientFilePath "index.js" @@ -222,9 +222,9 @@ app = do (Just user, Just pswd) -> do queryResult <- runQuery $ insertUser user pswd case queryResult of - Left ex -> errorJson (400 :: Int) $ decodeUtf8 $ sqlErrorMsg ex - Right () -> text "all went well" - (_, _) -> errorJson (400 :: Int) ("Missing parameter" :: Text) + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex + Right () -> messageJson 200 "Tutto bene" + (_, _) -> messageJson 401 "Parametro mancante" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person From a3db405bdc482d5d9e15bc3fa7352d76f7f6e3ab Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 20 Sep 2019 09:53:00 +0200 Subject: [PATCH 24/73] Add doc, reduce repetitions --- src/Server.hs | 93 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 56 insertions(+), 37 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index b649cba..f73258e 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,7 +21,7 @@ import Data.Text import Data.Text.Encoding import Data.Time import Database.Beam -import Database.Beam.Postgres (Connection, sqlErrorMsg) +import Database.Beam.Postgres (Connection, SqlError, sqlErrorMsg) import GHC.Generics import Network.Wai.Middleware.Static import Query as Q @@ -93,7 +94,7 @@ getPoolOrConn conn = (Q.closeConnection) (PoolCfg 1 12 1) --- |Produces an error with the given code and description +-- |Sends a json message with the given code and description messageJson :: MonadIO m => Int -> Text -> ActionCtxT ctx m b messageJson code message = json @@ -102,9 +103,11 @@ messageJson code message = "error" .= object ["code" .= code, "message" .= message] ] +-- |Basic authentication level baseHook :: Monad m => ActionCtxT () m (HVect '[]) baseHook = return HNil +-- |Authorized user authentication level authHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) authHook = do oldCtx <- getContext @@ -114,6 +117,7 @@ authHook = do Nothing -> messageJson 401 "Utente non autorizzato" Just val -> return (val :&: oldCtx) +-- |Admin authorization level adminHook :: ActionCtxT (HVect ts1) (WebStateM Connection SessionVal st) (HVect (User : ts1)) adminHook = do oldCtx <- getContext @@ -121,11 +125,12 @@ adminHook = do mUser <- getUserFromSession case mUser of Nothing -> redirect "" - Just user -> + Just user -> case _userAdmin user of True -> return (user :&: oldCtx) False -> messageJson 401 "Admin non autorizzato" +-- |Function to get the user of the current session getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) getUserFromSession = do @@ -139,34 +144,46 @@ getUserFromSession = Right Nothing -> return Nothing Right (Just session) -> let (UserId id) = _sessionUtente session - in do + in do queryResult' <- runQuery $ selectUserFromUsername $ unpack id case queryResult' of Left ex -> return Nothing Right a -> return a +-- |Functions used to log in a user loginAction :: Text -> Text -> ApiAction ctx () loginAction user pswd = do - queryResult <- runQuery $ checkUser (unpack user) (unpack pswd) - case queryResult of - Left ex -> messageJson 500 "Problema durante l'autenticazione" - Right WrongUsername -> messageJson 401 "Username errata" - Right WrongPassword -> messageJson 401 "Password errata" - Right AllOk -> do - time <- liftIO getCurrentTime - insertResult <- runQuery $ insertSession (unpack user) time - case insertResult of - Right () -> do - mSession <- runQuery $ selectMostRecentSession $ unpack user - case mSession of - Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex - Right Nothing -> messageJson 666 "Spero seriamente che questo testo non sarà mai mostrato" - Right (Just session) -> - let sid = _sessionIdSessione session - in do - writeSession (Just sid) - redirect "app" - Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex + queryResult <- runQuery $ checkUser (unpack user) (unpack pswd) + case queryResult of + Left ex -> messageJson 500 "Problema durante l'autenticazione" + Right WrongUsername -> messageJson 401 "Username errata" + Right WrongPassword -> messageJson 401 "Password errata" + Right AllOk -> do + time <- liftIO getCurrentTime + insertResult <- runQuery $ insertSession (unpack user) time + case insertResult of + Right () -> do + mSession <- runQuery $ selectMostRecentSession $ unpack user + case mSession of + Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex + Right Nothing -> messageJson 666 "Spero seriamente che questo testo non sarà mai mostrato" + Right (Just session) -> + let sid = _sessionIdSessione session + in do + writeSession (Just sid) + redirect "app" + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex + +-- |Executes a query and sends the result as a json message +executeQueryAndSendResult + :: (HasSpock (ActionCtxT ctx m), ToJSON a, MonadIO m) + => (SpockConn (ActionCtxT ctx m) -> IO (Either SqlError a)) + -> ActionCtxT ctx m b +executeQueryAndSendResult query = do + queryResult <- runQuery query + case queryResult of + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex + Right result -> json result -- server functions runServer :: ApiCfg -> IO () @@ -194,23 +211,24 @@ app = do case (maybeUser, maybePswd) of (Just user, Just pswd) -> loginAction user pswd (_, _) -> messageJson 401 "Parametro mancante" - get "login.js" $ - file "application/javascript" $ getClientFilePath "login.js" - get ("login.css") $ - file "text/css" $ getClientFilePath "login.css" + get "login.js" + $ file "application/javascript" + $ getClientFilePath "login.js" + get ("login.css") + $ file "text/css" + $ getClientFilePath "login.css" prehook authHook $ do -- routes for authenticated users get "app" $ do file "text/html" $ getClientFilePath "index.html" get "people" $ do - queryResult <- runQuery selectAllPeople - case queryResult of - Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex - Right allPeople -> json allPeople - get "index.js" $ - file "application/javascript" $ getClientFilePath "index.js" - get ("index.css") $ - file "text/css" $ getClientFilePath "index.css" + executeQueryAndSendResult selectAllPeople + get "index.js" + $ file "application/javascript" + $ getClientFilePath "index.js" + get ("index.css") + $ file "text/css" + $ getClientFilePath "index.css" prehook adminHook $ do -- routes for authenticated admins get "manager" $ do @@ -221,10 +239,11 @@ app = do case (maybeUser, maybePswd) of (Just user, Just pswd) -> do queryResult <- runQuery $ insertUser user pswd - case queryResult of + case queryResult of Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex Right () -> messageJson 200 "Tutto bene" (_, _) -> messageJson 401 "Parametro mancante" + -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person From 0850eabb3e49b2f7643bea05249db06f3b2d18a0 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 20 Sep 2019 10:17:40 +0200 Subject: [PATCH 25/73] Add routes for requesting data --- src/Server.hs | 40 +++++++++++++++++++++++++++++++++++----- 1 file changed, 35 insertions(+), 5 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index f73258e..72781fa 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -174,12 +174,12 @@ loginAction user pswd = do redirect "app" Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex --- |Executes a query and sends the result as a json message -executeQueryAndSendResult +-- |Executes a query that returns a list and sends the result as a json message +executeQueryListAndSendResult :: (HasSpock (ActionCtxT ctx m), ToJSON a, MonadIO m) - => (SpockConn (ActionCtxT ctx m) -> IO (Either SqlError a)) + => (SpockConn (ActionCtxT ctx m) -> IO (Either SqlError [a])) -> ActionCtxT ctx m b -executeQueryAndSendResult query = do +executeQueryListAndSendResult query = do queryResult <- runQuery query case queryResult of Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex @@ -222,7 +222,37 @@ app = do get "app" $ do file "text/html" $ getClientFilePath "index.html" get "people" $ do - executeQueryAndSendResult selectAllPeople + executeQueryListAndSendResult selectAllPeople + get "cutterOperators" $ do + executeQueryListAndSendResult selectAllLaserCutterOperators + get "printerOperators" $ do + executeQueryListAndSendResult selectAllPrinterOperators + get "materials" $ do + executeQueryListAndSendResult selectAllMaterials + get "materials_classes" $ do + executeQueryListAndSendResult selectAllMaterialsClasses + get "processings" $ do + executeQueryListAndSendResult selectAllProcessings + get "types" $ do + executeQueryListAndSendResult selectAllTypes + get "filaments" $ do + executeQueryListAndSendResult selectAllFilaments + get "plastics" $ do + executeQueryListAndSendResult selectAllPlastics + get "printers" $ do + executeQueryListAndSendResult selectAllPrinters + get "prints" $ do + executeQueryListAndSendResult selectAllPrints + get "incomplete_prints" $ do + executeQueryListAndSendResult selectAllIncompletePrints + get "complete_prints" $ do + executeQueryListAndSendResult selectAllCompletePrints + get "cuts" $ do + executeQueryListAndSendResult selectAllCuts + get "incomplete_cuts" $ do + executeQueryListAndSendResult selectAllIncompleteCuts + get "complete_cuts" $ do + executeQueryListAndSendResult selectAllCompleteCuts get "index.js" $ file "application/javascript" $ getClientFilePath "index.js" From 464b3f0ccffacc1292608c0ec703030ce8979581 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 20 Sep 2019 10:30:53 +0200 Subject: [PATCH 26/73] Add base files --- client/index.css | 0 client/index.html | 0 client/index.js | 0 client/login.css | 0 client/login.html | 0 client/login.js | 0 6 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 client/index.css create mode 100644 client/index.html create mode 100644 client/index.js create mode 100644 client/login.css create mode 100644 client/login.html create mode 100644 client/login.js diff --git a/client/index.css b/client/index.css new file mode 100644 index 0000000..e69de29 diff --git a/client/index.html b/client/index.html new file mode 100644 index 0000000..e69de29 diff --git a/client/index.js b/client/index.js new file mode 100644 index 0000000..e69de29 diff --git a/client/login.css b/client/login.css new file mode 100644 index 0000000..e69de29 diff --git a/client/login.html b/client/login.html new file mode 100644 index 0000000..e69de29 diff --git a/client/login.js b/client/login.js new file mode 100644 index 0000000..e69de29 From c1da739c8ba8ebb7478e18c709478090a0a8375f Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 17:16:08 +0200 Subject: [PATCH 27/73] Add login page --- client/index.html | 33 +++++++++++++++++++++++++++++++++ client/login.html | 22 ++++++++++++++++++++++ client/login.js | 13 +++++++++++++ 3 files changed, 68 insertions(+) diff --git a/client/index.html b/client/index.html index e69de29..1b77d95 100644 --- a/client/index.html +++ b/client/index.html @@ -0,0 +1,33 @@ + + + + + + + Menù + + + +
+ +
+ Anagrafiche + Stampe + Intagli + Materiali + Plastiche +
+
+
+
+ +
+
+
+ +
+ + + \ No newline at end of file diff --git a/client/login.html b/client/login.html index e69de29..3822453 100644 --- a/client/login.html +++ b/client/login.html @@ -0,0 +1,22 @@ + + + + + + + Login + + + +
+
+ Username: +
+ Password: +
+ +
+
+ + + \ No newline at end of file diff --git a/client/login.js b/client/login.js index e69de29..df8d082 100644 --- a/client/login.js +++ b/client/login.js @@ -0,0 +1,13 @@ +document.getElementById("submit_button").onclick = function() { + var xhr = new XMLHttpRequest(); + var fd = new FormData(document.getElementById("login_form")); + xhr.onreadystatechange = function() { + if (xhr.readyState == 4 && xhr.status != 200) { + var error = JSON.parse(xhr.responseText).error.message; + var text = document.createTextNode("Login fallito"); + document.getElementById("container").appendChild(text); + } + } + xhr.open("POST", window.location.href.toString() + "/login"); + xhr.send(fd); +} \ No newline at end of file From 17328bca0bd89c35310141a290132d827d617ac7 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 18:25:52 +0200 Subject: [PATCH 28/73] Correct messageJson function --- src/Server.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 72781fa..1f2d368 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -99,8 +99,7 @@ messageJson :: MonadIO m => Int -> Text -> ActionCtxT ctx m b messageJson code message = json $ object - [ "result" .= String "failure", - "error" .= object ["code" .= code, "message" .= message] + [ "response" .= object ["code" .= code, "message" .= message] ] -- |Basic authentication level From 850f0d530f6dc311c6f6932fae7a8737ae68c2bd Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 20:49:13 +0200 Subject: [PATCH 29/73] Correct use of text --- src/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index 1f2d368..613c3ca 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -164,7 +164,7 @@ loginAction user pswd = do Right () -> do mSession <- runQuery $ selectMostRecentSession $ unpack user case mSession of - Left ex -> text $ decodeUtf8 $ sqlErrorMsg ex + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex Right Nothing -> messageJson 666 "Spero seriamente che questo testo non sarà mai mostrato" Right (Just session) -> let sid = _sessionIdSessione session From 8ca010643e8e4e0cff52a495b862527beae00128 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 20:57:16 +0200 Subject: [PATCH 30/73] Add login css and javascript --- client/login.css | 79 +++++++++++++++++++++++++++++++++++++++++++++++ client/login.html | 10 +++--- client/login.js | 33 +++++++++++++------- 3 files changed, 105 insertions(+), 17 deletions(-) diff --git a/client/login.css b/client/login.css index e69de29..28a7f38 100644 --- a/client/login.css +++ b/client/login.css @@ -0,0 +1,79 @@ +body { + background-color: #51ff51; + font-family: 'Asap', sans-serif; +} +#login_form { + overflow: hidden; + background-color: white; + padding: 10px 20px 30px 30px; + border-radius: 10px; + position: absolute; + top: 50%; + left: 50%; + width: 400px; + transform: translate(-50%, -50%); + transition: transform 300ms, box-shadow 300ms; + box-shadow: 3px 3px 3px #ff8181; +} +#login_form::before, #login_form::after { + content: ''; + position: absolute; + width: 600px; + height: 600px; + border-top-left-radius: 40%; + border-top-right-radius: 45%; + border-bottom-left-radius: 35%; + border-bottom-right-radius: 40%; + z-index: -1; +} +#login_form::before { + left: 40%; + bottom: -130%; + background-color: rgba(255, 83, 83, 0.15); + animation: waves 6s infinite linear; +} +#login_form::after { + left: 35%; + bottom: -125%; + background-color: rgba(255, 129, 129, 0.2); + animation: waves 7s infinite; +} +input { + font-family: 'Asap', sans-serif; + display: block; + border-radius: 5px; + font-size: 16px; + background: white; + width: 100%; + border: 0; + padding: 10px 10px; + margin: 15px -10px; +} +button { + font-family: 'Asap', sans-serif; + cursor: pointer; + color: white; + font-size: 16px; + text-transform: uppercase; + width: 80px; + border: 0; + padding: 10px 0; + margin-top: 10px; + margin-left: -5px; + border-radius: 5px; + background-color: #51ff51; +} +button:hover { + background-color: #38ff38; +} +#login_error { + color: #a61a1a; +} +@keyframes waves { + from { + transform: rotate(0); + } + to { + transform: rotate(360deg); + } +} diff --git a/client/login.html b/client/login.html index 3822453..4b9536d 100644 --- a/client/login.html +++ b/client/login.html @@ -9,12 +9,10 @@
-
- Username: -
- Password: -
- + +
+
+
diff --git a/client/login.js b/client/login.js index df8d082..3483aba 100644 --- a/client/login.js +++ b/client/login.js @@ -1,13 +1,24 @@ -document.getElementById("submit_button").onclick = function() { - var xhr = new XMLHttpRequest(); - var fd = new FormData(document.getElementById("login_form")); - xhr.onreadystatechange = function() { - if (xhr.readyState == 4 && xhr.status != 200) { - var error = JSON.parse(xhr.responseText).error.message; - var text = document.createTextNode("Login fallito"); - document.getElementById("container").appendChild(text); - } +window.onload = function() { + document.getElementById('submit_button').onclick = function() { + var form = new FormData(document.getElementById('login_form')); + var post = { + method: 'POST', + body: form + }; + fetch(window.location.href.toString() + 'login', post).then(function(response) { + if (!response.redirected && response.ok) { + response.json().then(jsonResponse => { + if (jsonResponse["response"]["code"] == "401") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.id = "login_error"; + document.getElementById('login_form') + .appendChild(error); + } + }); + } else if (response.redirected == true) { + window.location.replace(response.url); + } + }); } - xhr.open("POST", window.location.href.toString() + "/login"); - xhr.send(fd); } \ No newline at end of file From 0223af16c94a90ce03ff8d51aadc3c69bcd4bc05 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 21:33:06 +0200 Subject: [PATCH 31/73] Fix login problem, refine css --- client/login.css | 33 ++++++++++++++++++++------------- client/login.html | 4 ++-- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/client/login.css b/client/login.css index 28a7f38..169ea5a 100644 --- a/client/login.css +++ b/client/login.css @@ -1,5 +1,5 @@ body { - background-color: #51ff51; + background-color: #9eff9e; font-family: 'Asap', sans-serif; } #login_form { @@ -10,16 +10,16 @@ body { position: absolute; top: 50%; left: 50%; - width: 400px; + width: 40%; transform: translate(-50%, -50%); transition: transform 300ms, box-shadow 300ms; - box-shadow: 3px 3px 3px #ff8181; + box-shadow: 3px 3px 3px #ff7d7d; } #login_form::before, #login_form::after { content: ''; position: absolute; - width: 600px; - height: 600px; + width: 50rem; + height: 50rem; border-top-left-radius: 40%; border-top-right-radius: 45%; border-bottom-left-radius: 35%; @@ -29,13 +29,13 @@ body { #login_form::before { left: 40%; bottom: -130%; - background-color: rgba(255, 83, 83, 0.15); + background-color: rgba(255, 184, 184, 0.15); animation: waves 6s infinite linear; } #login_form::after { left: 35%; bottom: -125%; - background-color: rgba(255, 129, 129, 0.2); + background-color: rgba(255, 125, 125, 0.2); animation: waves 7s infinite; } input { @@ -44,6 +44,7 @@ input { border-radius: 5px; font-size: 16px; background: white; + color: #142114; width: 100%; border: 0; padding: 10px 10px; @@ -52,22 +53,28 @@ input { button { font-family: 'Asap', sans-serif; cursor: pointer; - color: white; + color: #26a929; font-size: 16px; text-transform: uppercase; - width: 80px; + width: auto; border: 0; - padding: 10px 0; + padding: 8px 5px 8px 5px; margin-top: 10px; margin-left: -5px; border-radius: 5px; - background-color: #51ff51; + background-color: #9eff9e; } button:hover { - background-color: #38ff38; + background-color: #7dff7d; } #login_error { - color: #a61a1a; + color: #a62929; + width: 100%; + border: 0; + padding: 10px 0; + margin-top: 10px; + margin-left: -5px; + margin-bottom: -15px; } @keyframes waves { from { diff --git a/client/login.html b/client/login.html index 4b9536d..294798a 100644 --- a/client/login.html +++ b/client/login.html @@ -9,10 +9,10 @@
-
+

- +
From fffb2462dc0d2e8890f91fcca01bc703cdbb4e6d Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sat, 21 Sep 2019 22:33:04 +0200 Subject: [PATCH 32/73] Add partial html and css for index --- client/index.css | 74 +++++++++++++++++++++++++++++++++-------------- client/index.html | 39 ++++++++++++++++--------- client/login.css | 4 +-- 3 files changed, 79 insertions(+), 38 deletions(-) diff --git a/client/index.css b/client/index.css index 1a3efcc..0ea5420 100644 --- a/client/index.css +++ b/client/index.css @@ -1,31 +1,61 @@ -.dropbtn { - background-color: black; - color: white; - padding: 16px; - font-size: 16px; - border: none; +body { + background-color: #b8ffb8; + font-family: 'Asap', sans-serif; } .menu { - position: relative; - display: inline-block; + background-color: #ffb8b8; + color: #a62929; + box-shadow: 0 1px 3px 0 rgba(255, 125, 125, 0.12), 0 1px 2px 0 rgba(255, 125, 125, 0.24); + border-radius: 3px; } -.dropdown-content { - display: none; - position: absolute; - background-color: lightgrey; - min-width: 200px; - z-index: 1; +.menu_item:hover { + background-color: #7dff7d; + color: #29a629; } -.dropdown-content a { - color: black; - padding: 12px 16px; - text-decoration: none; - display: block; +.menu_list { + display: flex; + text-align: center; + padding-left: 0; + margin-top: 0; + margin-bottom: 0; + list-style: none; } -.dropdown-content a:hover {background-color: white;} -.menu:hover .dropdown-content {display: block;} -.menu:hover .dropbtn {background-color: grey;} +.menu_item { + flex-grow: 1; + padding: 5px; +} + +.sub_menu { + display: none; + position: absolute; + border-radius: 5px; + background-color: #9eff9e; + z-index: 1; + list-style: none; + margin: 0.5px; + padding: 15px; + padding-top: 3px; + padding-bottom: 3px; + box-shadow: 0 2px 3px 0 rgba(41, 166, 41, 0.12), 0 2px 3px 0 rgba(41, 166, 41, 0.24) +} + +.sub_menu_item { + color: #294a29; + padding: 3px 3px; + border-radius: 3px; + text-decoration: none; + display: flex; +} + +.sub_menu_item:hover { + background-color: #b8ffb8; + color: rgba(41, 74, 41, 0.75); +} + +.menu_item:hover .sub_menu { + display: block; +} \ No newline at end of file diff --git a/client/index.html b/client/index.html index 1b77d95..60c0ac3 100644 --- a/client/index.html +++ b/client/index.html @@ -8,22 +8,33 @@ -
- -
- Anagrafiche - Stampe - Intagli - Materiali - Plastiche -
+
+
-
- -
+
+ +
diff --git a/client/login.css b/client/login.css index 169ea5a..cac3ae0 100644 --- a/client/login.css +++ b/client/login.css @@ -1,5 +1,5 @@ body { - background-color: #9eff9e; + background-color: #b8ffb8; font-family: 'Asap', sans-serif; } #login_form { @@ -62,7 +62,7 @@ button { margin-top: 10px; margin-left: -5px; border-radius: 5px; - background-color: #9eff9e; + background-color: #b8ffb8; } button:hover { background-color: #7dff7d; From 16755510a38029aa11dba822b851ad0555a07717 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 22 Sep 2019 12:01:42 +0200 Subject: [PATCH 33/73] Correct colors, complete html structure --- client/index.css | 38 ++++++++++++++++++--------- client/index.html | 67 ++++++++++++++++++++++++++++++++++++----------- client/login.css | 27 +++++++++++++------ 3 files changed, 97 insertions(+), 35 deletions(-) diff --git a/client/index.css b/client/index.css index 0ea5420..c25cea0 100644 --- a/client/index.css +++ b/client/index.css @@ -1,18 +1,32 @@ +/* +Colors: + base: #d30068, complement + background: #c2f56e light light green + sub menu focus: #aff53d light green + menu focus: #92ec00 green + sub menu shadow: #7eb12c dark green + menu focus text/sub menu text: #5f9900 dark dark green + menu shadow2: #e93a90 light red + menu shadow1: #d30068 red + menu background: #e969a8 ligh light red + menu text: #890043 dark dark red +*/ + body { - background-color: #b8ffb8; + background-color: #c2f56e; font-family: 'Asap', sans-serif; } .menu { - background-color: #ffb8b8; - color: #a62929; - box-shadow: 0 1px 3px 0 rgba(255, 125, 125, 0.12), 0 1px 2px 0 rgba(255, 125, 125, 0.24); + background-color: #e969a8; + color: #890043; + box-shadow: 0 1px 3px 0 rgba(211, 0, 104, 0.12), 0 1px 2px 0 rgba(233, 58, 144, 0.24); border-radius: 3px; } .menu_item:hover { - background-color: #7dff7d; - color: #29a629; + background-color: #92ec00; + color: #5f9900; } .menu_list { @@ -33,18 +47,18 @@ body { display: none; position: absolute; border-radius: 5px; - background-color: #9eff9e; + background-color: #ffffff; z-index: 1; list-style: none; - margin: 0.5px; + margin: 1px; padding: 15px; padding-top: 3px; - padding-bottom: 3px; - box-shadow: 0 2px 3px 0 rgba(41, 166, 41, 0.12), 0 2px 3px 0 rgba(41, 166, 41, 0.24) + padding-bottom: 5px; + box-shadow: 0 2px 3px 0 rgba(126, 177, 44, 0.12), 0 2px 3px 0 rgba(126, 177, 44, 0.24) } .sub_menu_item { - color: #294a29; + color: #5f9900; padding: 3px 3px; border-radius: 3px; text-decoration: none; @@ -52,7 +66,7 @@ body { } .sub_menu_item:hover { - background-color: #b8ffb8; + background-color: #aff53d; color: rgba(41, 74, 41, 0.75); } diff --git a/client/index.html b/client/index.html index 60c0ac3..2ab3b2d 100644 --- a/client/index.html +++ b/client/index.html @@ -14,27 +14,64 @@ + + + + + - - - - -
-
- -
+
diff --git a/client/login.css b/client/login.css index cac3ae0..eca717b 100644 --- a/client/login.css +++ b/client/login.css @@ -1,5 +1,16 @@ +/* +Colors: + base: #d30068, complement + background: #c2f56e light light green + focus button: #aff53d light green + font button: #5f9900 dark dark green + shadow1/wave2: #e93a90 light red + wave1: #e969a8 ligh light red + error: #890043 dark dark red +*/ + body { - background-color: #b8ffb8; + background-color: #c2f56e; font-family: 'Asap', sans-serif; } #login_form { @@ -13,7 +24,7 @@ body { width: 40%; transform: translate(-50%, -50%); transition: transform 300ms, box-shadow 300ms; - box-shadow: 3px 3px 3px #ff7d7d; + box-shadow: 3px 3px 3px #e93a90; } #login_form::before, #login_form::after { content: ''; @@ -29,13 +40,13 @@ body { #login_form::before { left: 40%; bottom: -130%; - background-color: rgba(255, 184, 184, 0.15); + background-color: rgba(233, 58, 144, 0.15); animation: waves 6s infinite linear; } #login_form::after { left: 35%; bottom: -125%; - background-color: rgba(255, 125, 125, 0.2); + background-color: rgba(233, 105, 168, 0.2); animation: waves 7s infinite; } input { @@ -53,7 +64,7 @@ input { button { font-family: 'Asap', sans-serif; cursor: pointer; - color: #26a929; + color: #5f9900; font-size: 16px; text-transform: uppercase; width: auto; @@ -62,13 +73,13 @@ button { margin-top: 10px; margin-left: -5px; border-radius: 5px; - background-color: #b8ffb8; + background-color: #c2f56e; } button:hover { - background-color: #7dff7d; + background-color: #aff53d; } #login_error { - color: #a62929; + color: #890043; width: 100%; border: 0; padding: 10px 0; From 6ba65a8cb3d884eef0928fbe85bc4049711a5d43 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 22 Sep 2019 12:55:32 +0200 Subject: [PATCH 34/73] Add insert person operation --- client/index.css | 61 ++++++++++++++++++++++++++++++++++++++++ client/index.js | 73 ++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 120 insertions(+), 14 deletions(-) diff --git a/client/index.css b/client/index.css index c25cea0..216e7a1 100644 --- a/client/index.css +++ b/client/index.css @@ -72,4 +72,65 @@ body { .menu_item:hover .sub_menu { display: block; +} + +#user_input { + overflow: hidden; + background-color: transparent; + padding: 10px 20px 30px 30px; + border-radius: 10px; + position: absolute; + top: 20%; + left: 10%; + width: 80%; +} + +.input_form { + overflow: hidden; + background-color: white; + padding: 10px 20px 30px 30px; + border-radius: 10px; + transition: transform 300ms, box-shadow 300ms; + box-shadow: 3px 3px 3px #e93a90; +} +input { + font-family: 'Asap', sans-serif; + display: block; + border-radius: 5px; + font-size: 16px; + background: white; + color: #142114; + width: 100%; + border: 0; + padding: 10px 10px; + margin: 15px -10px; +} +input:focus { + border: 1px solid #c2f56e; +} +button { + font-family: 'Asap', sans-serif; + cursor: pointer; + color: #5f9900; + font-size: 16px; + text-transform: uppercase; + width: auto; + border: 0; + padding: 8px 5px 8px 5px; + margin-top: 10px; + margin-left: -5px; + border-radius: 5px; + background-color: #c2f56e; +} +button:hover { + background-color: #aff53d; +} +.error { + color: #890043; + width: 100%; + border: 0; + padding: 10px 0; + margin-top: 10px; + margin-left: -5px; + margin-bottom: -15px; } \ No newline at end of file diff --git a/client/index.js b/client/index.js index 11ff445..3c43e8d 100644 --- a/client/index.js +++ b/client/index.js @@ -1,17 +1,68 @@ -base_url = 'http://localhost:8080/' +window.onload = function() { + document.getElementById("insert_person").onclick = () => insertPerson(); +} + +function insertPerson() { + var inputDiv = document.getElementById("user_input"); + inputDiv.innerHTML = ""; + var form = document.createElement("form"); + form.method = "POST"; + form.enctype = "multipart/form-data"; + form.classList.add("input_form"); + var cfInput = createTextInput("cf", "Codice fiscale"); + var nameInput = createTextInput("name", "Nome"); + var surnameInput = createTextInput("surname", "Cognome"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + button.onclick = sendInsertData(form, "add_person"); + form.appendChild(cfInput); + form.appendChild(nameInput); + form.appendChild(surnameInput); + form.appendChild(button); + inputDiv.appendChild(form); +} -function set_json_data(url, selectId, setter) { - var html_code = ''; +function sendInsertData(form, route) { + var fd = new FormData(form); + var post = { + method: "POST", + body: form + }; + fetch(window.location.href.toString() + route, post).then(function(response) { + if (response.ok) { + response.json().then(jsonResponse => { + if (jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } + }); + } + }); +} + +function createTextInput(name, placeholder) { + var input = document.createElement("input"); + input.type = "text"; + input.name = name; + input.placeholder = placeholder; + return input; +} + +function setJsonData(url, selectId, setter) { + var html_code = ""; var xhr = new XMLHttpRequest(); xhr.onreadystatechange = function() { if (xhr.readyState == 4 && xhr.status == 200) setter(selectId, JSON.parse(xhr.responseText)); } - xhr.open('GET', url, true); + xhr.open("GET", url, true); xhr.send(); } -function set_select_list(selectId, options) { +function setSelectList(selectId, options) { var selectElement = document.getElementById(selectId); while (selectElement.options.length) { selectElement.remove(0); @@ -23,12 +74,6 @@ function set_select_list(selectId, options) { } } -function set_all_people(selectId) { - set_json_data(base_url.concat('people'), selectId, set_select_list); -} - -function initWindow() { - set_all_people('select_richiedenti'); -} - -window.onload = initWindow(); \ No newline at end of file +function setAllPeopl(selectId) { + setJsonData(window.location.href + "people", selectId, setSelectList); +} \ No newline at end of file From 3ca61df792c49fa23dd32a0b45a993eb62bb398a Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 22 Sep 2019 15:01:31 +0200 Subject: [PATCH 35/73] Add post routes --- src/Server.hs | 252 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 241 insertions(+), 11 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 613c3ca..fe6da5d 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -17,6 +17,8 @@ import Data.Aeson hiding (json) import qualified Data.Configurator as C import Data.HVect import Data.List as L (groupBy) +import Data.Maybe +import Data.Scientific import Data.Text import Data.Text.Encoding import Data.Time @@ -184,6 +186,23 @@ executeQueryListAndSendResult query = do Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex Right result -> json result +-- |Executes a query to insert or modify some data and sends the result as a json message +executeModifyQueryAndSendResult + :: (HasSpock (ActionCtxT ctx m), MonadIO m) + => (SpockConn (ActionCtxT ctx m) -> IO (Either SqlError ())) + -> ActionCtxT ctx m b +executeModifyQueryAndSendResult query = do + queryResult <- runQuery query + case queryResult of + Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex + Right () -> messageJson 200 "Operazione riuscita" + +testParameters :: [Maybe a] -> Bool +testParameters = (Prelude.all id) . (fmap isJust) + +toBool :: String -> Bool +toBool = flip elem ["true", "True", "TRUE"] + -- server functions runServer :: ApiCfg -> IO () runServer cfg = @@ -207,9 +226,12 @@ app = do post "login" $ do maybeUser <- param "username" maybePswd <- param "password" - case (maybeUser, maybePswd) of - (Just user, Just pswd) -> loginAction user pswd - (_, _) -> messageJson 401 "Parametro mancante" + if testParameters [maybeUser, maybePswd] + then + loginAction + (fromJust maybeUser) + (fromJust maybePswd) + else messageJson 422 "Parametro mancante" get "login.js" $ file "application/javascript" $ getClientFilePath "login.js" @@ -220,6 +242,188 @@ app = do -- routes for authenticated users get "app" $ do file "text/html" $ getClientFilePath "index.html" + post "insert_person" $ do + maybeCf <- param "cf" + maybeName <- param "name" + maybeSurname <- param "surname" + if testParameters [maybeCf, maybeName, maybeSurname] + then + executeModifyQueryAndSendResult + $ insertPerson + (fromJust maybeCf) + (fromJust maybeName) + (fromJust maybeSurname) + else messageJson 422 "Parametro mancante" + post "modify_person" $ do + maybeCf <- param "cf" + maybePartner <- param "partner" + maybeCutter <- param "cutter" + maybePrinter <- param "printer" + if testParameters [maybeCf, maybePartner, maybeCutter, maybePrinter] + then + executeModifyQueryAndSendResult + $ modifyPerson + (fromJust maybeCf) + (toBool $ fromJust maybePartner) + (toBool $ fromJust maybeCutter) + (toBool $ fromJust maybePrinter) + else messageJson 422 "Parametro mancante" + post "insert_class" $ do + maybeCode <- param "code" + maybeName <- param "name" + if testParameters [maybeCode, maybeName] + then + executeModifyQueryAndSendResult + $ insertMaterialsClass + (fromJust maybeCode) + (fromJust maybeName) + else messageJson 422 "Parametro mancante" + post "insert_material" $ do + maybeCode <- param "code" + maybeClass <- param "class" + maybeName <- param "name" + maybeWidth <- param "width" + maybeDescr <- param "description" + if testParameters [maybeCode, maybeClass, maybeName, maybeWidth, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertMaterial + (fromJust maybeCode) + (fromJust maybeClass) + (fromJust maybeName) + (read $ fromJust maybeWidth :: Double) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "insert_processing" $ do + maybeTypeCode <- param "type" + maybeMaterialCode <- param "material" + maybeMaxP <- param "max_potency" + maybeMinP <- param "min_potency" + maybeSpeed <- param "speed" + maybeDescr <- param "description" + if testParameters [maybeTypeCode, maybeMaterialCode, maybeMaxP, maybeMinP, maybeSpeed, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertProcessing + (fromJust maybeTypeCode) + (fromJust maybeMaterialCode) + (read $ fromJust maybeMaxP :: Int) + (read $ fromJust maybeMinP :: Int) + (read $ fromJust maybeSpeed :: Int) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "insert_plastic" $ do + maybeCode <- param "code" + maybeName <- param "name" + maybeDescr <- param "description" + if testParameters [maybeCode, maybeName, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertPlastic + (fromJust maybeCode) + (fromJust maybeName) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "insert_filament" $ do + maybeCode <- param "code" + maybePlastic <- param "plastic" + maybeBrand <- param "brand" + maybeColor <- param "color" + if testParameters [maybeCode, maybePlastic, maybeBrand, maybeColor] + then + executeModifyQueryAndSendResult + $ insertFilament + (fromJust maybeCode) + (fromJust maybePlastic) + (fromJust maybeBrand) + (fromJust maybeColor) + else messageJson 422 "Parametro mancante" + post "insert_print" $ do + maybeCf <- param "client" + maybeDate <- param "date" + maybeDescr <- param "descr" + if testParameters [maybeCf, maybeDate, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertPrint + (fromJust maybeCf) + (read $ fromJust maybeDate :: Day) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "assign_print_operator" $ do + maybeCf <- param "operator" + maybeCode <- param "print" + if testParameters [maybeCode, maybeCf] + then + executeModifyQueryAndSendResult + $ assignPrint + (read $ fromJust maybeCode :: Int) + (fromJust maybeCf) + else messageJson 422 "Parametro mancante" + post "assign_print_printer" $ do + maybeCodePrinter <- param "printer" + maybeCode <- param "print" + if testParameters [maybeCode, maybeCodePrinter] + then + executeModifyQueryAndSendResult + $ assignPrinter + (fromJust maybeCodePrinter) + (read $ fromJust maybeCode :: Int) + else messageJson 422 "Parametro mancante" + post "modify_print" $ do + maybePrint <- param "print" + maybeDate <- param "date" + maybeTime <- param "time" + maybeTotal <- param "total" + maybeMaterials <- param "materials" + if testParameters [maybePrint, maybeTime, maybeTotal, maybeMaterials, maybeDate] + then + executeModifyQueryAndSendResult + $ completePrint + (read $ fromJust maybePrint :: Int) + (read $ fromJust maybeDate :: Day) + (read $ fromJust maybeTime :: Double) + (read $ fromJust maybeTotal :: Scientific) + (read $ fromJust maybeMaterials :: Scientific) + else messageJson 422 "Parametro mancante" + post "insert_cut" $ do + maybeCf <- param "client" + maybeDate <- param "date" + maybeDescr <- param "descr" + if testParameters [maybeCf, maybeDate, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertCut + (fromJust maybeCf) + (read $ fromJust maybeDate :: Day) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "assign_cut_operator" $ do + maybeCf <- param "operator" + maybeCode <- param "print" + if testParameters [maybeCode, maybeCf] + then + executeModifyQueryAndSendResult + $ assignCut + (read $ fromJust maybeCode :: Int) + (fromJust maybeCf) + else messageJson 422 "Parametro mancante" + post "modify_cut" $ do + maybeCut <- param "cut" + maybeDate <- param "date" + maybeTime <- param "time" + maybeTotal <- param "total" + maybeMaterials <- param "materials" + if testParameters [maybeCut, maybeTime, maybeTotal, maybeMaterials, maybeDate] + then + executeModifyQueryAndSendResult + $ completeCut + (read $ fromJust maybeCut :: Int) + (read $ fromJust maybeDate :: Day) + (read $ fromJust maybeTime :: Double) + (read $ fromJust maybeTotal :: Scientific) + (read $ fromJust maybeMaterials :: Scientific) + else messageJson 422 "Parametro mancante" get "people" $ do executeQueryListAndSendResult selectAllPeople get "cutterOperators" $ do @@ -262,16 +466,42 @@ app = do -- routes for authenticated admins get "manager" $ do text "with great power comes great responsability!" - post "newUser" $ do + post "insert_type" $ do + maybeCode <- param "code" + maybeName <- param "name" + maybeDescr <- param "description" + if testParameters [maybeCode, maybeName, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertType + (fromJust maybeCode) + (fromJust maybeName) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "insert_printer" $ do + maybeCode <- param "code" + maybeBrand <- param "brand" + maybeModel <- param "model" + maybeDescr <- param "description" + if testParameters [maybeCode, maybeBrand, maybeModel, maybeDescr] + then + executeModifyQueryAndSendResult + $ insertPrinter + (fromJust maybeCode) + (fromJust maybeBrand) + (fromJust maybeDescr) + (fromJust maybeDescr) + else messageJson 422 "Parametro mancante" + post "insert_user" $ do maybeUser <- param "username" maybePswd <- param "password" - case (maybeUser, maybePswd) of - (Just user, Just pswd) -> do - queryResult <- runQuery $ insertUser user pswd - case queryResult of - Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex - Right () -> messageJson 200 "Tutto bene" - (_, _) -> messageJson 401 "Parametro mancante" + if testParameters [maybeUser, maybePswd] + then + executeModifyQueryAndSendResult + $ insertUser + (fromJust maybeUser) + (fromJust maybePswd) + else messageJson 401 "Parametro mancante" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person From 1c2d15ca4b871fba1fe60a2a3886e64a9f6e218b Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 23 Sep 2019 18:58:10 +0200 Subject: [PATCH 36/73] Add link to fonts, add new operations --- client/index.css | 78 +++++++++++++++++++++++++++++++++-- client/index.html | 7 ++-- client/index.js | 103 ++++++++++++++++++++++++++++++++++++++++------ client/login.css | 1 + 4 files changed, 169 insertions(+), 20 deletions(-) diff --git a/client/index.css b/client/index.css index 216e7a1..acf4a6f 100644 --- a/client/index.css +++ b/client/index.css @@ -11,6 +11,7 @@ Colors: menu background: #e969a8 ligh light red menu text: #890043 dark dark red */ +@import url('https://fonts.googleapis.com/css?family=Asap&display=swap'); body { background-color: #c2f56e; @@ -85,7 +86,11 @@ body { width: 80%; } -.input_form { +#input_form.hidden { + display: none; +} + +#input_form { overflow: hidden; background-color: white; padding: 10px 20px 30px 30px; @@ -93,7 +98,7 @@ body { transition: transform 300ms, box-shadow 300ms; box-shadow: 3px 3px 3px #e93a90; } -input { +input[type="text"], input[type="password"] { font-family: 'Asap', sans-serif; display: block; border-radius: 5px; @@ -105,7 +110,7 @@ input { padding: 10px 10px; margin: 15px -10px; } -input:focus { +input[type="text"]:focus, input[type="password"]:focus { border: 1px solid #c2f56e; } button { @@ -133,4 +138,69 @@ button:hover { margin-top: 10px; margin-left: -5px; margin-bottom: -15px; -} \ No newline at end of file +} +.ok { + color: #5f9900; + width: 100%; + border: 0; + padding: 10px 0; + margin-top: 10px; + margin-left: -5px; + margin-bottom: -15px; +} + +#result { + margin: 10px; +} + +#filters_form.hidden { + display: none; +} + +#filters_form { + float: left; + clear: none; + top: 50%; + padding: 10px 10px 10px 10px; +} + +input[type=radio] { + float: left; + clear: none; +} + +label { + float: left; + display: block; + clear: none; +} + +#result_list.hidden { + display: none; +} + +#result_list { + overflow: hidden; + background-color: white; + padding: 10px 10px 10px 10px; + border-radius: 10px; + top: 50%; + transition: transform 300ms, box-shadow 300ms; + box-shadow: 3px 3px 3px #e93a90; + text-align: center; +} + +#result_elem.hidden{ + display: none; +} + +.result_elem { + font-family: 'Asap', sans-serif; + list-style: none; + font-size: 16px; + color: #142114; + margin-top: 10px; + margin-bottom: 5px; + border-bottom: 1px solid #c2f56e; +} + diff --git a/client/index.html b/client/index.html index 2ab3b2d..b5e8c77 100644 --- a/client/index.html +++ b/client/index.html @@ -17,8 +17,6 @@ - -
- +
- + +
diff --git a/client/index.js b/client/index.js index 3c43e8d..8782a3a 100644 --- a/client/index.js +++ b/client/index.js @@ -1,42 +1,109 @@ window.onload = function() { document.getElementById("insert_person").onclick = () => insertPerson(); + document.getElementById("show_people").onclick = () => showPeople(); } function insertPerson() { - var inputDiv = document.getElementById("user_input"); - inputDiv.innerHTML = ""; - var form = document.createElement("form"); - form.method = "POST"; - form.enctype = "multipart/form-data"; - form.classList.add("input_form"); + clearPage(); + var form = document.getElementById("input_form"); + form.classList.remove("hidden"); var cfInput = createTextInput("cf", "Codice fiscale"); var nameInput = createTextInput("name", "Nome"); var surnameInput = createTextInput("surname", "Cognome"); var button = document.createElement("button"); button.type = "button"; button.innerHTML = "Inserisci"; - button.onclick = sendInsertData(form, "add_person"); form.appendChild(cfInput); form.appendChild(nameInput); form.appendChild(surnameInput); form.appendChild(button); - inputDiv.appendChild(form); + button.onclick = () => sendInsertData("input_form", "insert_person"); } -function sendInsertData(form, route) { +function showPeople() { + clearPage(); + var form = document.getElementById("filters_form"); + form.classList.remove("hidden"); + // TODO: apply filters + createFiltersCheckBoxes(form, ["partners", "Soci"], ["cutters", "Operatori intagliatrice"], ["printers", "Operatori stampante"]); + var resultDiv = document.getElementById("result"); + var resultList = document.getElementById("result_list"); + resultList.classList.remove("hidden"); + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + "people").then(function(response) { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + resultDiv.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + for (const index in jsonResponse) { + var listElem = document.createElement("li"); + var person = jsonResponse[index]; + listElem.classList.add("result_elem"); + listElem.innerHTML = person._personNome + " " + person._personCognome + " -- " + person._personCf; + resultList.appendChild(listElem); + } + } + }); + } + }); +} + +function clearPage() { + var hideableElements = document.getElementsByClassName("hideable"); + for (var i = 0; i < hideableElements.length; i++) { + hideableElements[i].classList.add("hidden"); + while (hideableElements[i].firstChild) { + hideableElements[i].removeChild(hideableElements[i].firstChild); + } + } +} + +function createFiltersCheckBoxes(form, ...checkBoxes) { + checkBoxes.forEach(box => { + var input = document.createElement("input"); + var label = document.createElement("label"); + input.type = "radio"; + input.name = "radio_" + form.id; + input.id = box[0]; + label.for = input.id; + label.innerHTML = box[1]; + form.appendChild(input); + form.appendChild(label); + form.appendChild(document.createElement("br")); + }); +} + +function sendInsertData(formId, route) { + var form = document.getElementById(formId); var fd = new FormData(form); var post = { method: "POST", - body: form + body: fd }; - fetch(window.location.href.toString() + route, post).then(function(response) { + var errors = form.getElementsByClassName("error"); + while (errors.length > 0) { + errors.item(0).parentNode.removeChild(errors.item(0)); + } + var oks = form.getElementsByClassName("ok"); + while (oks.length > 0) { + oks.item(0).parentNode.removeChild(oks.item(0)); + } + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route, post).then(function(response) { if (response.ok) { response.json().then(jsonResponse => { - if (jsonResponse["response"]["code"] != "200") { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { var error = document.createElement("P"); error.innerHTML = jsonResponse["response"]["message"]; error.classList.add("error"); form.appendChild(error); + } else if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] == "200") { + var ok = document.createElement("P"); + ok.innerHTML = jsonResponse["response"]["message"]; + ok.classList.add("ok"); + form.appendChild(ok); } }); } @@ -62,6 +129,18 @@ function setJsonData(url, selectId, setter) { xhr.send(); } +function getJsonData(route) { + fetch(window.location.href.toString() + route).then(function(response) { + if (response.ok) { + response.json().then(jsonResponse => {return jsonResponse}); + } + }); +} + +function checkIfJsonIsError(json) { + return json.hasOwnProperty("response"); +} + function setSelectList(selectId, options) { var selectElement = document.getElementById(selectId); while (selectElement.options.length) { diff --git a/client/login.css b/client/login.css index eca717b..1a3a693 100644 --- a/client/login.css +++ b/client/login.css @@ -8,6 +8,7 @@ Colors: wave1: #e969a8 ligh light red error: #890043 dark dark red */ +@import url('https://fonts.googleapis.com/css?family=Asap&display=swap'); body { background-color: #c2f56e; From f25f5dfb21d22e03771c3926e021d1b294c12ec4 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 26 Sep 2019 08:45:42 +0200 Subject: [PATCH 37/73] Add query for selecting partners and its route --- src/Query.hs | 4 ++++ src/Server.hs | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/src/Query.hs b/src/Query.hs index ceadee0..3a5c386 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -100,6 +100,10 @@ prepareName = toTitle . pack selectAllPeople :: Connection -> IO (Either SqlError [Person]) selectAllPeople = genericSelectList _persone Nothing +-- |Select all partners in the database +selectAllPartners :: Connection -> IO (Either SqlError [Person]) +selectAllPartners = genericSelectList _persone $ Just (\p -> _personSocio p ==. (val_ True)) + -- |Select all laser cutter operators in the database selectAllLaserCutterOperators :: Connection -> IO (Either SqlError [Person]) selectAllLaserCutterOperators = diff --git a/src/Server.hs b/src/Server.hs index fe6da5d..8990aaa 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -197,9 +197,11 @@ executeModifyQueryAndSendResult query = do Left ex -> messageJson 500 $ decodeUtf8 $ sqlErrorMsg ex Right () -> messageJson 200 "Operazione riuscita" +-- |Checks if a list of Maybe contains all Just values or not testParameters :: [Maybe a] -> Bool testParameters = (Prelude.all id) . (fmap isJust) +-- |Converts a String to a Bool, with "true", "True" and "TRUE" corresponding to True toBool :: String -> Bool toBool = flip elem ["true", "True", "TRUE"] @@ -426,6 +428,8 @@ app = do else messageJson 422 "Parametro mancante" get "people" $ do executeQueryListAndSendResult selectAllPeople + get "partners" $ do + executeQueryListAndSendResult selectAllPartners get "cutterOperators" $ do executeQueryListAndSendResult selectAllLaserCutterOperators get "printerOperators" $ do From 8b79bfa637ef79ae7a0a4927109cd2e8f53d11d5 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 26 Sep 2019 12:10:48 +0200 Subject: [PATCH 38/73] Correct clients list placement --- client/index.css | 18 +++++++++--------- client/index.js | 24 ++++++++++++++++++------ 2 files changed, 27 insertions(+), 15 deletions(-) diff --git a/client/index.css b/client/index.css index acf4a6f..c5f91f0 100644 --- a/client/index.css +++ b/client/index.css @@ -158,21 +158,19 @@ button:hover { } #filters_form { - float: left; - clear: none; - top: 50%; + display: inline-block; padding: 10px 10px 10px 10px; + box-sizing: border-box; + width: 30%; + vertical-align: middle; } input[type=radio] { - float: left; - clear: none; + display: inline-block; } label { - float: left; - display: block; - clear: none; + display: inline-block; } #result_list.hidden { @@ -184,10 +182,12 @@ label { background-color: white; padding: 10px 10px 10px 10px; border-radius: 10px; - top: 50%; + display: inline-block; + width: 68%; transition: transform 300ms, box-shadow 300ms; box-shadow: 3px 3px 3px #e93a90; text-align: center; + vertical-align: middle; } #result_elem.hidden{ diff --git a/client/index.js b/client/index.js index 8782a3a..368bf37 100644 --- a/client/index.js +++ b/client/index.js @@ -3,6 +3,7 @@ window.onload = function() { document.getElementById("show_people").onclick = () => showPeople(); } +/* creates the form and sends the data to insert a new person in the database */ function insertPerson() { clearPage(); var form = document.getElementById("input_form"); @@ -20,16 +21,21 @@ function insertPerson() { button.onclick = () => sendInsertData("input_form", "insert_person"); } +/* creates the list to show the people in the database, with the appropriate filters */ function showPeople() { clearPage(); var form = document.getElementById("filters_form"); form.classList.remove("hidden"); - // TODO: apply filters - createFiltersCheckBoxes(form, ["partners", "Soci"], ["cutters", "Operatori intagliatrice"], ["printers", "Operatori stampante"]); + createFiltersCheckBoxes(form, "people_type", ["all", "Tutti", "people"], ["partners", "Soci", "partners"], ["cutters", "Operatori intagliatrice", "cutterOperators"], ["printers", "Operatori stampante", "printerOperators"]); + setList("people"); +} + +/* sets the content of the "result_list" element with the results from the given route */ +function setList(route) { var resultDiv = document.getElementById("result"); var resultList = document.getElementById("result_list"); resultList.classList.remove("hidden"); - fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + "people").then(function(response) { + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(function(response) { if (response.ok) { response.json().then(jsonResponse => { if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { @@ -38,6 +44,7 @@ function showPeople() { error.classList.add("error"); resultDiv.appendChild(error); } else if (!checkIfJsonIsError(jsonResponse)) { + result_list.innerHTML = ""; for (const index in jsonResponse) { var listElem = document.createElement("li"); var person = jsonResponse[index]; @@ -48,9 +55,10 @@ function showPeople() { } }); } - }); + }); } +/* clears the page */ function clearPage() { var hideableElements = document.getElementsByClassName("hideable"); for (var i = 0; i < hideableElements.length; i++) { @@ -61,13 +69,15 @@ function clearPage() { } } -function createFiltersCheckBoxes(form, ...checkBoxes) { +/* creates a variable number of checkboxes into the form, with [name, label, route] properties */ +function createFiltersCheckBoxes(form, name, ...checkBoxes) { checkBoxes.forEach(box => { var input = document.createElement("input"); var label = document.createElement("label"); input.type = "radio"; - input.name = "radio_" + form.id; + input.name = name; input.id = box[0]; + input.onclick = () => { if (input.checked) { setList(box[2]); } }; label.for = input.id; label.innerHTML = box[1]; form.appendChild(input); @@ -76,6 +86,7 @@ function createFiltersCheckBoxes(form, ...checkBoxes) { }); } +/* sends to the said route the content of the given form, giving a visual notice of the result of the operation */ function sendInsertData(formId, route) { var form = document.getElementById(formId); var fd = new FormData(form); @@ -110,6 +121,7 @@ function sendInsertData(formId, route) { }); } +/* creates a text input, with the given name and placeholder */ function createTextInput(name, placeholder) { var input = document.createElement("input"); input.type = "text"; From 3dd4ac173bb17522a4a3d342245b3bbd25232ba1 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 26 Sep 2019 12:31:49 +0200 Subject: [PATCH 39/73] Correct queries to complete prints and cuts --- src/Query.hs | 88 +++++++++++++++++++++++++++++++++++----------------- 1 file changed, 60 insertions(+), 28 deletions(-) diff --git a/src/Query.hs b/src/Query.hs index 3a5c386..55747e2 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -499,20 +499,36 @@ assignFilament pCode fCode = -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completePrint pCode deliveryDate workTime total materials = - \conn -> - try - $ runBeam conn - $ runUpdate - $ update (_stampe fabLabDB) - ( \s -> - mconcat - [ _printDataConsegna s <-. val_ (Just deliveryDate), - _printCostoMateriali s <-. val_ (Just materials), - _printCostoTotale s <-. val_ (Just total), - _printTempo s <-. val_ (Just workTime) - ] - ) - (\s -> _printCodiceStampa s ==. val_ pCode) + \conn -> do + completeResult <- + try + $ runBeam conn + $ runUpdate + $ update (_stampe fabLabDB) + ( \s -> + mconcat + [ _printDataConsegna s <-. val_ (Just deliveryDate), + _printCostoMateriali s <-. val_ (Just materials), + _printCostoTotale s <-. val_ (Just total), + _printTempo s <-. val_ (Just workTime) + ] + ) + (\s -> _printCodiceStampa s ==. val_ pCode) + case completeResult of + Left ex -> return $ Left ex + Right () -> do + maybePrint <- selectPrintFromCode pCode conn + case maybePrint of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "Inconsistent state: a print existed, and then no more!" "" "" + Right (Just print) -> + let (PersonId cf) = _printCfRichiedente print + in try + $ runBeam conn + $ runUpdate + $ update (_persone fabLabDB) + (\p -> _personSpesaTotale p <-. (current_ (_personSpesaTotale p) + (val_ total))) + (\p -> _personCf p ==. val_ cf) -- cuts queries -- |Select the cut with the given code in the database (should be 0 or 1) @@ -601,17 +617,33 @@ assignProcessing cCode pCode = -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completeCut code deliveryDate workTime total materials = - \conn -> - try - $ runBeam conn - $ runUpdate - $ update (_intagli fabLabDB) - ( \c -> - mconcat - [ _cutDataConsegna c <-. val_ (Just deliveryDate), - _cutCostoTotale c <-. val_ (Just total), - _cutCostoMateriali c <-. val_ (Just materials), - _cutTempo c <-. val_ (Just workTime) - ] - ) - (\c -> _cutCodiceIntaglio c ==. val_ code) + \conn -> do + completeResult <- + try + $ runBeam conn + $ runUpdate + $ update (_intagli fabLabDB) + ( \s -> + mconcat + [ _cutDataConsegna s <-. val_ (Just deliveryDate), + _cutCostoMateriali s <-. val_ (Just materials), + _cutCostoTotale s <-. val_ (Just total), + _cutTempo s <-. val_ (Just workTime) + ] + ) + (\s -> _cutCodiceIntaglio s ==. val_ code) + case completeResult of + Left ex -> return $ Left ex + Right () -> do + maybeCut <- selectCutFromCode code conn + case maybeCut of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "Inconsistent state: a cut existed, and then no more!" "" "" + Right (Just cut) -> + let (PersonId cf) = _cutCfRichiedente cut + in try + $ runBeam conn + $ runUpdate + $ update (_persone fabLabDB) + (\p -> _personSpesaTotale p <-. (current_ (_personSpesaTotale p) + (val_ total))) + (\p -> _personCf p ==. val_ cf) From 3962f83a4e31d0467b6886ec89b23887e585e58a Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 27 Sep 2019 23:09:10 +0200 Subject: [PATCH 40/73] Change to result area structure --- client/index.css | 73 ++++++++++++++++++++++++++++------------------- client/index.html | 14 +++++---- client/index.js | 56 +++++++++++++++++++++++++++++------- 3 files changed, 96 insertions(+), 47 deletions(-) diff --git a/client/index.css b/client/index.css index c5f91f0..99e69f6 100644 --- a/client/index.css +++ b/client/index.css @@ -17,33 +17,36 @@ body { background-color: #c2f56e; font-family: 'Asap', sans-serif; } - +.fixed { + /* position: fixed; */ + width: 99%; + min-height: 5%; +} +.scrollable { + /* padding-top: 2.5%; */ +} .menu { background-color: #e969a8; color: #890043; box-shadow: 0 1px 3px 0 rgba(211, 0, 104, 0.12), 0 1px 2px 0 rgba(233, 58, 144, 0.24); - border-radius: 3px; + border-radius: 3px; } - -.menu_item:hover { - background-color: #92ec00; - color: #5f9900; -} - .menu_list { display: flex; text-align: center; padding-left: 0; margin-top: 0; margin-bottom: 0; - list-style: none; + list-style: none; } - .menu_item { flex-grow: 1; padding: 5px; } - +.menu_item:hover { + background-color: #92ec00; + color: #5f9900; +} .sub_menu { display: none; position: absolute; @@ -55,9 +58,11 @@ body { padding: 15px; padding-top: 3px; padding-bottom: 5px; - box-shadow: 0 2px 3px 0 rgba(126, 177, 44, 0.12), 0 2px 3px 0 rgba(126, 177, 44, 0.24) + box-shadow: 0 2px 3px 0 rgba(126, 177, 44, 0.12), 0 2px 3px 0 rgba(126, 177, 44, 0.24); +} +.sub_menu:hover { + display: block; } - .sub_menu_item { color: #5f9900; padding: 3px 3px; @@ -65,16 +70,13 @@ body { text-decoration: none; display: flex; } - .sub_menu_item:hover { background-color: #aff53d; color: rgba(41, 74, 41, 0.75); } - .menu_item:hover .sub_menu { display: block; } - #user_input { overflow: hidden; background-color: transparent; @@ -85,7 +87,6 @@ body { left: 10%; width: 80%; } - #input_form.hidden { display: none; } @@ -156,51 +157,63 @@ button:hover { #filters_form.hidden { display: none; } - #filters_form { display: inline-block; padding: 10px 10px 10px 10px; box-sizing: border-box; - width: 30%; + width: 25%; vertical-align: middle; } - input[type=radio] { display: inline-block; } - label { display: inline-block; } -#result_list.hidden { +#result_area.hidden { display: none; } - -#result_list { +#result_area { overflow: hidden; background-color: white; padding: 10px 10px 10px 10px; border-radius: 10px; display: inline-block; - width: 68%; + width: 73%; transition: transform 300ms, box-shadow 300ms; box-shadow: 3px 3px 3px #e93a90; text-align: center; vertical-align: middle; } - +#result_table { + width: 100%; + line-height: 1.5em; + border-spacing: 0; + border-radius: 10px; +} #result_elem.hidden{ display: none; } - +#name, #surname, #expense { + width: 20%; + background: #c2f56e; +} +#expense { + border-top-right-radius: 10px; +} +#cf { + width: 40%; + background: #c2f56e; + border-top-left-radius: 10px; +} .result_elem { font-family: 'Asap', sans-serif; - list-style: none; font-size: 16px; color: #142114; - margin-top: 10px; - margin-bottom: 5px; + border-bottom: 1px solid #c2f56e; +} +td { border-bottom: 1px solid #c2f56e; } diff --git a/client/index.html b/client/index.html index b5e8c77..b9c163d 100644 --- a/client/index.html +++ b/client/index.html @@ -68,12 +68,14 @@
-
- -
-
- - +
+
+ +
+
+ + +
diff --git a/client/index.js b/client/index.js index 368bf37..aa141cb 100644 --- a/client/index.js +++ b/client/index.js @@ -27,31 +27,40 @@ function showPeople() { var form = document.getElementById("filters_form"); form.classList.remove("hidden"); createFiltersCheckBoxes(form, "people_type", ["all", "Tutti", "people"], ["partners", "Soci", "partners"], ["cutters", "Operatori intagliatrice", "cutterOperators"], ["printers", "Operatori stampante", "printerOperators"]); - setList("people"); + setTable("people"); } -/* sets the content of the "result_list" element with the results from the given route */ -function setList(route) { - var resultDiv = document.getElementById("result"); - var resultList = document.getElementById("result_list"); - resultList.classList.remove("hidden"); +/* sets the content of the "result_area" element with the results from the given route */ +function setTable(route) { + var resultDiv = document.getElementById("result_area"); fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(function(response) { if (response.ok) { response.json().then(jsonResponse => { if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + showClearElem("result_area"); var error = document.createElement("P"); error.innerHTML = jsonResponse["response"]["message"]; error.classList.add("error"); resultDiv.appendChild(error); } else if (!checkIfJsonIsError(jsonResponse)) { - result_list.innerHTML = ""; + showClearElem("result_area"); + var resultTable = createTable("result_table", "headers", ["cf", "Codice fiscale"], ["name", "Nome"], ["surname", "Cognome"], ["expense", "Spesa totale"]); for (const index in jsonResponse) { - var listElem = document.createElement("li"); + var listElem = document.createElement("tr"); var person = jsonResponse[index]; listElem.classList.add("result_elem"); - listElem.innerHTML = person._personNome + " " + person._personCognome + " -- " + person._personCf; - resultList.appendChild(listElem); + var nameCell = document.createElement("td"); + nameCell.innerHTML = person._personNome; + var surnameCell = document.createElement("td"); + surnameCell.innerHTML = person._personCognome; + var cfCell = document.createElement("td"); + cfCell.innerHTML = person._personCf; + var expenseCell = document.createElement("td"); + expenseCell.innerHTML = person._personSpesaTotale + " €"; + listElem.append(cfCell, nameCell, surnameCell, expenseCell); + resultTable.appendChild(listElem); } + resultDiv.appendChild(resultTable); } }); } @@ -69,6 +78,15 @@ function clearPage() { } } +/* makes visible the element with elemId, as if it was created anew */ +function showClearElem(elemId) { + var elem = document.getElementById(elemId); + while(elem.firstChild) { + elem.removeChild(elem.firstChild); + } + elem.classList.remove("hidden"); +} + /* creates a variable number of checkboxes into the form, with [name, label, route] properties */ function createFiltersCheckBoxes(form, name, ...checkBoxes) { checkBoxes.forEach(box => { @@ -77,7 +95,7 @@ function createFiltersCheckBoxes(form, name, ...checkBoxes) { input.type = "radio"; input.name = name; input.id = box[0]; - input.onclick = () => { if (input.checked) { setList(box[2]); } }; + input.onclick = () => { if (input.checked) { setTable(box[2]); } }; label.for = input.id; label.innerHTML = box[1]; form.appendChild(input); @@ -130,6 +148,22 @@ function createTextInput(name, placeholder) { return input; } +/* creates a table with the given id, id of the headers and columns [headerId, name] */ +function createTable(tableId, headersId, ...headers) { + var resultTable = document.createElement("table"); + resultTable.id = tableId; + var header = document.createElement("tr") + header.id = headersId; + resultTable.appendChild(header); + headers.forEach(h => { + var th = document.createElement("th"); + th.id = h[0]; + th.innerHTML = h[1]; + header.appendChild(th); + }); + return resultTable; +} + function setJsonData(url, selectId, setter) { var html_code = ""; var xhr = new XMLHttpRequest(); From b4972f9edd4cfbb79c9b3e67112101fd5203243d Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 30 Sep 2019 20:07:49 +0200 Subject: [PATCH 41/73] Add js for modify person function --- client/index.css | 26 ++++++- client/index.js | 172 ++++++++++++++++++++++++++++++++++------------- 2 files changed, 152 insertions(+), 46 deletions(-) diff --git a/client/index.css b/client/index.css index 99e69f6..10f1fbf 100644 --- a/client/index.css +++ b/client/index.css @@ -13,6 +13,9 @@ Colors: */ @import url('https://fonts.googleapis.com/css?family=Asap&display=swap'); +.hidden { + display: none; +} body { background-color: #c2f56e; font-family: 'Asap', sans-serif; @@ -202,7 +205,7 @@ label { #expense { border-top-right-radius: 10px; } -#cf { +th#cf { width: 40%; background: #c2f56e; border-top-left-radius: 10px; @@ -217,3 +220,24 @@ td { border-bottom: 1px solid #c2f56e; } +select { + font-family: 'Asap', sans-serif; + font-size: 16px; + color: #142114; + padding: 2px; + border-radius: 3px; + border-color: #c2f56e; + -moz-appearance: none; + display: inline-block; + margin: 10px; +} +input[type="checkbox"].hidden { + display: none; +} +input[type="checkbox"] { + font-family: 'Asap', sans-serif; + font-size: 16px; + color: #142114; + display: inline-block; + margin: 7px; +} diff --git a/client/index.js b/client/index.js index aa141cb..4ae9781 100644 --- a/client/index.js +++ b/client/index.js @@ -1,13 +1,14 @@ window.onload = function() { document.getElementById("insert_person").onclick = () => insertPerson(); document.getElementById("show_people").onclick = () => showPeople(); + document.getElementById("modify_person").onclick = () => modifyPeople(); } /* creates the form and sends the data to insert a new person in the database */ function insertPerson() { clearPage(); var form = document.getElementById("input_form"); - form.classList.remove("hidden"); + showClearElem(form.id); var cfInput = createTextInput("cf", "Codice fiscale"); var nameInput = createTextInput("name", "Nome"); var surnameInput = createTextInput("surname", "Cognome"); @@ -18,7 +19,7 @@ function insertPerson() { form.appendChild(nameInput); form.appendChild(surnameInput); form.appendChild(button); - button.onclick = () => sendInsertData("input_form", "insert_person"); + button.onclick = () => sendFormData("input_form", "insert_person"); } /* creates the list to show the people in the database, with the appropriate filters */ @@ -26,14 +27,63 @@ function showPeople() { clearPage(); var form = document.getElementById("filters_form"); form.classList.remove("hidden"); - createFiltersCheckBoxes(form, "people_type", ["all", "Tutti", "people"], ["partners", "Soci", "partners"], ["cutters", "Operatori intagliatrice", "cutterOperators"], ["printers", "Operatori stampante", "printerOperators"]); + createFiltersRadioButtons(form, "people_type", ["all", "Tutti", "people"], ["partners", "Soci", "partners"], ["cutters", "Operatori intagliatrice", "cutterOperators"], ["printers", "Operatori stampante", "printerOperators"]); setTable("people"); } +/* show the appropriate forms to modify a person */ +function modifyPeople() { + clearPage(); + var form = document.getElementById("input_form"); + showClearElem(form.id); + fetch(window.location.protocol + "//" + window.location.host.toString() + "/people").then(response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + var list = document.createElement("select"); + list.name = "cf"; + list.id = "cf_select"; + form.appendChild(list); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = jsonResponse[index]._personCf; + elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; + list.appendChild(elem); + } + list.onchange = () => changeCheckedBoxes(); + changeCheckedBoxes(); + form.appendChild(document.createElement("br")); + createFiltersCheckBoxes(form, ["partner", "true", "Socio"], ["cutter", "true", "Operatore intagliatrice"], ["printer", "true", "Operatore stampante"]); + createHiddenFiltersCheckBoxes(form, ["partner", "false", "Socio"], ["cutter", "false", "Operatore intagliatrice"], ["printer", "false", "Operatore stampante"]); + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Modifica"; + okButton.onclick = () => { + disableCheckBoxes(form); + sendFormData("input_form", "modify_person") + }; + form.appendChild(okButton); + } + }); + } + }); +} + +/* fetches data from the given route, and executes the given action */ +function fetchData(route, action) { + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(action); +} + /* sets the content of the "result_area" element with the results from the given route */ function setTable(route) { var resultDiv = document.getElementById("result_area"); - fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(function(response) { + fetchData() + fetchData(route, function(response) { if (response.ok) { response.json().then(jsonResponse => { if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { @@ -87,31 +137,98 @@ function showClearElem(elemId) { elem.classList.remove("hidden"); } -/* creates a variable number of checkboxes into the form, with [name, label, route] properties */ -function createFiltersCheckBoxes(form, name, ...checkBoxes) { - checkBoxes.forEach(box => { +/* creates a variable number of radio buttons into the form, with [name, label, route] properties */ +function createFiltersRadioButtons(form, name, ...radioButtons) { + radioButtons.forEach(button => { var input = document.createElement("input"); var label = document.createElement("label"); input.type = "radio"; input.name = name; + input.id = button[0]; + input.onclick = () => { if (input.checked) { setTable(button[2]); } }; + label.for = input.id; + label.innerHTML = button[1]; + form.appendChild(input); + form.appendChild(label); + form.appendChild(document.createElement("br")); + }); +} + +/* creates a variable number of checkBoxes into the form, with [name, value, label] properties */ +function createFiltersCheckBoxes(form, ...checkBoxes) { + checkBoxes.forEach(box => { + var input = document.createElement("input"); + var label = document.createElement("label"); + input.type = "checkbox"; + input.name = box[0]; + input.value = box[1]; input.id = box[0]; - input.onclick = () => { if (input.checked) { setTable(box[2]); } }; label.for = input.id; - label.innerHTML = box[1]; + label.innerHTML = box[2]; form.appendChild(input); form.appendChild(label); form.appendChild(document.createElement("br")); }); } +/* creates a variable number of checkBoxes into the form, with [name, value, label] properties, that have the "hidden" class */ +function createHiddenFiltersCheckBoxes(form, ...checkBoxes) { + checkBoxes.forEach(box => { + var input = document.createElement("input"); + input.type = "checkbox"; + input.name = box[0]; + input.value = box[1]; + input.checked = true; + input.id = box[0] + "_hidden"; + input.classList.add("hidden"); + form.appendChild(input); + }); +} + +/* change the checked boxes based on the value of the "cf_select" element */ +function changeCheckedBoxes() { + var list = document.getElementById("cf_select"); + fetchData("people", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (!checkIfJsonIsError(jsonResponse)) { + for (const index in jsonResponse) { + if (list.value == jsonResponse[index]._personCf) { + document.getElementById("partner").checked = jsonResponse[index]._personSocio; + document.getElementById("cutter").checked = jsonResponse[index]._personOperatoreIntagliatrice; + document.getElementById("printer").checked = jsonResponse[index]._personOperatoreStampante; + } + } + } + }); + } + }); +} + +/* disables the invisibles checkboxes if the visible ones are checked */ +function disableCheckBoxes(form) { + var checkBoxes = document.getElementsByTagName("input"); + for (const index in checkBoxes) { + var box = checkBoxes.item(index); + if (box.type == "checkbox" && box.classList.contains("hidden")) { + var shownId = box.id.split("_")[0]; + var shownBox = document.getElementById(shownId); + if (shownBox.checked) { + box.disabled = true; + } + } + } +} + /* sends to the said route the content of the given form, giving a visual notice of the result of the operation */ -function sendInsertData(formId, route) { +function sendFormData(formId, route) { var form = document.getElementById(formId); var fd = new FormData(form); var post = { method: "POST", body: fd }; + console.log(form); var errors = form.getElementsByClassName("error"); while (errors.length > 0) { errors.item(0).parentNode.removeChild(errors.item(0)); @@ -164,41 +281,6 @@ function createTable(tableId, headersId, ...headers) { return resultTable; } -function setJsonData(url, selectId, setter) { - var html_code = ""; - var xhr = new XMLHttpRequest(); - xhr.onreadystatechange = function() { - if (xhr.readyState == 4 && xhr.status == 200) - setter(selectId, JSON.parse(xhr.responseText)); - } - xhr.open("GET", url, true); - xhr.send(); -} - -function getJsonData(route) { - fetch(window.location.href.toString() + route).then(function(response) { - if (response.ok) { - response.json().then(jsonResponse => {return jsonResponse}); - } - }); -} - function checkIfJsonIsError(json) { return json.hasOwnProperty("response"); -} - -function setSelectList(selectId, options) { - var selectElement = document.getElementById(selectId); - while (selectElement.options.length) { - selectElement.remove(0); - } - for (var i = 0; i < options.length; i++) { - var opt = options[i]; - var str = opt._personNome.concat(" ", opt._personCognome, " ", opt._personCf); - selectElement.options.add(new Option(str, i)); - } -} - -function setAllPeopl(selectId) { - setJsonData(window.location.href + "people", selectId, setSelectList); } \ No newline at end of file From ec1a6c01b4e31b64cbcddf8dd422bb7dbb3cb455 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 30 Sep 2019 20:20:46 +0200 Subject: [PATCH 42/73] Add routes for selecting filaments and materials by type --- src/Server.hs | 48 +++++++++++++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 8990aaa..1451a52 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -205,6 +205,10 @@ testParameters = (Prelude.all id) . (fmap isJust) toBool :: String -> Bool toBool = flip elem ["true", "True", "TRUE"] +-- |Sends a message signalling a missing parameter +missingParameter :: MonadIO m => ActionCtxT ctx m b +missingParameter = messageJson 422 "Parametro mancante" + -- server functions runServer :: ApiCfg -> IO () runServer cfg = @@ -233,7 +237,7 @@ app = do loginAction (fromJust maybeUser) (fromJust maybePswd) - else messageJson 422 "Parametro mancante" + else missingParameter get "login.js" $ file "application/javascript" $ getClientFilePath "login.js" @@ -255,7 +259,7 @@ app = do (fromJust maybeCf) (fromJust maybeName) (fromJust maybeSurname) - else messageJson 422 "Parametro mancante" + else missingParameter post "modify_person" $ do maybeCf <- param "cf" maybePartner <- param "partner" @@ -269,7 +273,7 @@ app = do (toBool $ fromJust maybePartner) (toBool $ fromJust maybeCutter) (toBool $ fromJust maybePrinter) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_class" $ do maybeCode <- param "code" maybeName <- param "name" @@ -279,7 +283,7 @@ app = do $ insertMaterialsClass (fromJust maybeCode) (fromJust maybeName) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_material" $ do maybeCode <- param "code" maybeClass <- param "class" @@ -295,7 +299,12 @@ app = do (fromJust maybeName) (read $ fromJust maybeWidth :: Double) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter + post "select_materials" $ do + maybeCCode <- param "class_code" + case maybeCCode of + Nothing -> missingParameter + Just cCode -> executeQueryListAndSendResult $ selectMaterialsByClass cCode post "insert_processing" $ do maybeTypeCode <- param "type" maybeMaterialCode <- param "material" @@ -313,7 +322,7 @@ app = do (read $ fromJust maybeMinP :: Int) (read $ fromJust maybeSpeed :: Int) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_plastic" $ do maybeCode <- param "code" maybeName <- param "name" @@ -325,7 +334,7 @@ app = do (fromJust maybeCode) (fromJust maybeName) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_filament" $ do maybeCode <- param "code" maybePlastic <- param "plastic" @@ -339,7 +348,12 @@ app = do (fromJust maybePlastic) (fromJust maybeBrand) (fromJust maybeColor) - else messageJson 422 "Parametro mancante" + else missingParameter + post "select_filaments" $ do + maybePCode <- param "plastic_code" + case maybePCode of + Nothing -> missingParameter + Just code -> executeQueryListAndSendResult $ selectFilamentsByPlastic code post "insert_print" $ do maybeCf <- param "client" maybeDate <- param "date" @@ -351,7 +365,7 @@ app = do (fromJust maybeCf) (read $ fromJust maybeDate :: Day) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "assign_print_operator" $ do maybeCf <- param "operator" maybeCode <- param "print" @@ -361,7 +375,7 @@ app = do $ assignPrint (read $ fromJust maybeCode :: Int) (fromJust maybeCf) - else messageJson 422 "Parametro mancante" + else missingParameter post "assign_print_printer" $ do maybeCodePrinter <- param "printer" maybeCode <- param "print" @@ -371,7 +385,7 @@ app = do $ assignPrinter (fromJust maybeCodePrinter) (read $ fromJust maybeCode :: Int) - else messageJson 422 "Parametro mancante" + else missingParameter post "modify_print" $ do maybePrint <- param "print" maybeDate <- param "date" @@ -387,7 +401,7 @@ app = do (read $ fromJust maybeTime :: Double) (read $ fromJust maybeTotal :: Scientific) (read $ fromJust maybeMaterials :: Scientific) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_cut" $ do maybeCf <- param "client" maybeDate <- param "date" @@ -399,7 +413,7 @@ app = do (fromJust maybeCf) (read $ fromJust maybeDate :: Day) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "assign_cut_operator" $ do maybeCf <- param "operator" maybeCode <- param "print" @@ -409,7 +423,7 @@ app = do $ assignCut (read $ fromJust maybeCode :: Int) (fromJust maybeCf) - else messageJson 422 "Parametro mancante" + else missingParameter post "modify_cut" $ do maybeCut <- param "cut" maybeDate <- param "date" @@ -425,7 +439,7 @@ app = do (read $ fromJust maybeTime :: Double) (read $ fromJust maybeTotal :: Scientific) (read $ fromJust maybeMaterials :: Scientific) - else messageJson 422 "Parametro mancante" + else missingParameter get "people" $ do executeQueryListAndSendResult selectAllPeople get "partners" $ do @@ -481,7 +495,7 @@ app = do (fromJust maybeCode) (fromJust maybeName) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_printer" $ do maybeCode <- param "code" maybeBrand <- param "brand" @@ -495,7 +509,7 @@ app = do (fromJust maybeBrand) (fromJust maybeDescr) (fromJust maybeDescr) - else messageJson 422 "Parametro mancante" + else missingParameter post "insert_user" $ do maybeUser <- param "username" maybePswd <- param "password" From 34b0f8f1936fdb463aa73a3fde1bb4d3fc5277df Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Mon, 30 Sep 2019 20:56:05 +0200 Subject: [PATCH 43/73] Fix database schema, add plastics function --- client/index.css | 12 ++-- client/index.html | 1 + client/index.js | 150 +++++++++++++++++++++++++++++++++++++++------- 3 files changed, 135 insertions(+), 28 deletions(-) diff --git a/client/index.css b/client/index.css index 10f1fbf..ed1d1df 100644 --- a/client/index.css +++ b/client/index.css @@ -189,24 +189,26 @@ label { text-align: center; vertical-align: middle; } +#filters_form.hidden+#result_area { + width: 98%; +} #result_table { width: 100%; line-height: 1.5em; border-spacing: 0; border-radius: 10px; + table-layout: fixed; } #result_elem.hidden{ display: none; } -#name, #surname, #expense { - width: 20%; +th { background: #c2f56e; } -#expense { +th:last-of-type { border-top-right-radius: 10px; } -th#cf { - width: 40%; +th:first-of-type { background: #c2f56e; border-top-left-radius: 10px; } diff --git a/client/index.html b/client/index.html index b9c163d..7da9d50 100644 --- a/client/index.html +++ b/client/index.html @@ -56,6 +56,7 @@ + - + @@ -38,7 +38,7 @@ - + + @@ -63,6 +64,7 @@ Admin
    +
diff --git a/client/index.js b/client/index.js index ac2c0a2..0dadde9 100644 --- a/client/index.js +++ b/client/index.js @@ -9,6 +9,7 @@ window.onload = function() { document.getElementById("assign_print").onclick = () => assignPrint(); document.getElementById("complete_print").onclick = () => completePrint(); document.getElementById("assign_filament").onclick = () => assignFilament(); + document.getElementById("assign_printer").onclick = () => assignPrinter(); document.getElementById("show_prints").onclick = () => showPrints(); /* materials */ document.getElementById("insert_material").onclick = () => insertMaterial(); @@ -21,6 +22,7 @@ window.onload = function() { document.getElementById("show_plastics").onclick = () => showPlastics(); document.getElementById("show_filaments").onclick = () => showFilaments(); /* admins */ + document.getElementById("insert_printer").onclick = () => insertPrinter(); } /* @@ -134,22 +136,110 @@ PRINTS FUNCTIONS /* creates the form and sends the data to insert a new print */ function insertPrint() { - + clearPage(); + var form = document.getElementById("input_form"); + fetchData("people", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var peopleList = document.createElement("select"); + peopleList.name = "client"; + peopleList.id = "client_select"; + form.appendChild(peopleList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = jsonResponse[index]._personCf; + elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; + peopleList.appendChild(elem); + } + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var descrInput = createTextInput("descr", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(dateInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", "insert_print"); + } + }); + } + }); } /* assigns a print to an operator */ function assignPrint() { - + assignAToB("assign_print_operator", "prints", "printerOperators", "print", "operator", + print => print._printCodiceStampa, print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente), + operator => operator._personCf, operator => (operator._personNome + " " + operator._personCognome + " -- " + operator._personCf)); } /* completese a print */ function completePrint() { - + clearPage(); + var form = document.getElementById("input_form"); + fetchData("prints", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var list = document.createElement("select"); + list.name = "print"; + list.id = "print_select"; + form.appendChild(list); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = jsonResponse[index]._printCodiceStampa; + elem.innerHTML = jsonResponse[index]._printCodiceStampa + " -- " + jsonResponse[index]._printDataRichiesta + " -- " + jsonResponse[index]._printCfRichiedente; + list.appendChild(elem); + } + form.appendChild(document.createElement("br")); + var totalInput = createTextInput("total", "Costo totale (usare . per i decimali)"); + var materialInput = createTextInput("materials", "Costo materiali (usare . per i decimali)"); + var timeInput = createTextInput("time", "Tempo di completamento in ore (usare . per i decimali)"); + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Modifica"; + okButton.onclick = () => sendFormData("input_form", "modify_print"); + form.append(totalInput, materialInput, timeInput, dateInput, document.createElement("br"), okButton); + } + }); + } + }); } /* assigns a filament to a print */ function assignFilament() { + assignAToB("assign_print_filament", "prints", "filaments", "print", "filament", print => print._printCodiceStampa, + print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente), + filament => filament._filamentCodiceFilamento, + filament => (filament._filamentMarca + " " + filament._filamentColore)); +} +/* assigns a printer to a print */ +function assignPrinter() { + assignAToB("assign_print_printer", "printers", "prints", "printer", "print", printer => printer._printerCodiceStampante, + printer => (printer._printerMarca + " " + printer._printerModello), print => print._printCodiceStampa, + print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente)); } /* shows the prints */ @@ -500,6 +590,26 @@ ADMIN FUNCTIONS ---------------------------------------------------------------------------------------- */ +/* creates the form and insert a new printer in the database */ +function insertPrinter() { + clearPage(); + var form = document.getElementById("input_form"); + showClearElem(form.id); + var codeInput = createTextInput("code", "Codice stampante (3 caratteri)"); + var brandInput = createTextInput("brand", "Marca"); + var modelInput = createTextInput("model", "Modello"); + var descrInput = createTextInput("description", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(codeInput); + form.appendChild(brandInput); + form.appendChild(modelInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", "insert_printer"); +} + /* ---------------------------------------------------------------------------------------- GENERAL FUNCTIONS @@ -742,4 +852,63 @@ function createTable(tableId, headersId, ...headers) { function checkIfJsonIsError(json) { return json.hasOwnProperty("response"); +} + +function assignAToB(route, ARoute, BRoute, AName, BName, getACode, getAString, getBCode, getBString) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData(ARoute, responseA => { + if (responseA.ok) { + responseA.json().then(jsonResponseA => { + if (checkIfJsonIsError(jsonResponseA) && jsonResponseA["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseA["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseA)) { + fetchData(BRoute, responseB => { + if (responseB.ok) { + responseB.json().then(jsonResponseB => { + if (checkIfJsonIsError(jsonResponseB) && jsonResponseB["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseB["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseB)) { + showClearElem(form.id); + var AList = document.createElement("select"); + AList.name = AName; + AList.id = AName + "_select"; + form.appendChild(AList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseA) { + var elem = document.createElement("option"); + elem.value = getACode(jsonResponseA[index]); + elem.innerHTML = getAString(jsonResponseA[index]); + AList.appendChild(elem); + } + var BList = document.createElement("select"); + BList.name = BName; + BList.id = BName + "_select"; + form.appendChild(BList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseB) { + var elem = document.createElement("option"); + elem.value = getBCode(jsonResponseB[index]); + elem.innerHTML = getBString(jsonResponseB[index]); + BList.appendChild(elem); + } + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Assegna"; + okButton.onclick = () => sendFormData("input_form", route); + form.appendChild(okButton); + } + }); + } + }); + } + }); + } + }); } \ No newline at end of file From 6f14cd68d91972df1adb0594bda7a6e3c0a57cbc Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Thu, 3 Oct 2019 23:07:37 +0200 Subject: [PATCH 52/73] Add functions related to cuts --- client/index.js | 257 +++++++++++++++++++++++++++++++++--------------- 1 file changed, 179 insertions(+), 78 deletions(-) diff --git a/client/index.js b/client/index.js index 0dadde9..8062336 100644 --- a/client/index.js +++ b/client/index.js @@ -4,6 +4,13 @@ window.onload = function() { document.getElementById("show_people").onclick = () => showPeople(); document.getElementById("modify_person").onclick = () => modifyPerson(); /* cuts */ + document.getElementById("insert_cut").onclick = () => insertCut(); + document.getElementById("assign_cut").onclick = () => assignCut(); + document.getElementById("complete_cut").onclick = () => completeCut(); + document.getElementById("assign_processing").onclick = () => assignProcessing(); + document.getElementById("show_cuts").onclick = () => showCuts(); + document.getElementById("insert_processing").onclick = () => insertProcessing(); + document.getElementById("show_processings").onclick = () => showProcessings(); /* prints */ document.getElementById("insert_print").onclick = () => insertPrint(); document.getElementById("assign_print").onclick = () => assignPrint(); @@ -128,6 +135,86 @@ CUTS FUNCTIONS ---------------------------------------------------------------------------------------- */ +/* */ +function insertCut() { + insertWork("insert_cut"); +} + +/* */ +function assignCut() { + assignAToB("assign_cut_operator", "cuts", "cutterOperators", "cut", "operator", + cut => cut._cutCodiceIntaglio, cut => (cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente), + operator => operator._personCf, operator => (operator._personNome + " " + operator._personCognome + " -- " + operator._personCf)); +} + +/* */ +function completeCut() { + completeWork("cuts", "cut", cut => cut._cutCodiceIntaglio, + cut => (cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente), + "modify_cut"); +} + +/* */ +function assignProcessing() { + +} + +/* */ +function showCuts() { + clearPage(); + var form = document.getElementById("filters_form"); + form.classList.remove("hidden"); + var resultTable = createTable("result_table_works", "headers", ["code", "Cod. intaglio"], ["request_day", "Data richiesta"], + ["complete_day", "Data consegna"], ["client", "CF richiedente"]); + document.getElementById("result_area").appendChild(resultTable); + var setter = (jsonResponse, table) => { + var body = table.getElementsByTagName("tbody")[0]; + showClearElem(body.id); + for (const index in jsonResponse) { + var listElem = document.createElement("tr"); + var cut = jsonResponse[index]; + listElem.classList.add("result_elem"); + var codeCell = document.createElement("td"); + codeCell.innerHTML = cut._cutCodiceIntaglio; + var requestCell = document.createElement("td"); + requestCell.innerHTML = cut._cutDataRichiesta; + var completeCell = document.createElement("td"); + completeCell.innerHTML = cut._cutDataConsegna; + var clientCell = document.createElement("td"); + clientCell.innerHTML = cut._cutCfRichiedente; + var descrDiv = document.createElement("div"); + descrDiv.classList.add("complete_description"); + var descrPar = document.createElement("p"); + descrPar.innerHTML = "Codice intaglio: " + cut._cutCodiceIntaglio + + "
Data richiesta: " + cut._cutDataRichiesta + + "
Codice fiscale richiedente: " + cut._cutCfRichiedente + + "
Data consegna: " + (cut._cutDataConsegna == null ? "" : cut._cutDataConsegna) + + "
Costo totale: " + (cut._cutCostoTotale == null ? "" : cut._cutCostoTotale) + + "
Costo materiali: " + (cut._cutCostoMateriali == null ? "" : cut._cutCostoMateriali) + + "
Tempo esecuzione: " + (cut._cutTempo == null ? "" : cut._cutTempo) + + "
Codice fiscale incaricato: " + (cut._cutCfIncaricato == null ? "" : cut._cutCfIncaricato) + + "
Descrizione: " + (cut._cutDescrizione == null ? "" : cut._cutDescrizione); + descrDiv.appendChild(descrPar); + codeCell.appendChild(descrDiv); + listElem.append(codeCell, requestCell, completeCell, clientCell); + body.appendChild(listElem); + } + }; + createFiltersRadioButtons(form, resultTable, setter, "cut_type", ["all", "Tutte", "cuts"], ["complete", "Complete", "complete_cuts"], ["incomplete", "Incomplete", "incomplete_cuts"]); + setTable("cuts", resultTable, setter); +} + +/* */ +function insertProcessing() { + +} + +/* */ +function showProcessings() { + +} + + /* ---------------------------------------------------------------------------------------- PRINTS FUNCTIONS @@ -136,45 +223,7 @@ PRINTS FUNCTIONS /* creates the form and sends the data to insert a new print */ function insertPrint() { - clearPage(); - var form = document.getElementById("input_form"); - fetchData("people", response => { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponse)) { - showClearElem(form.id); - var peopleList = document.createElement("select"); - peopleList.name = "client"; - peopleList.id = "client_select"; - form.appendChild(peopleList); - form.appendChild(document.createElement("br")); - for (const index in jsonResponse) { - var elem = document.createElement("option"); - elem.value = jsonResponse[index]._personCf; - elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; - peopleList.appendChild(elem); - } - var dateInput = document.createElement("input"); - dateInput.type = "date"; - dateInput.name = "date"; - dateInput.placeholder = "gg/mm/aaaa"; - var descrInput = createTextInput("descr", "Descrizione"); - var button = document.createElement("button"); - button.type = "button"; - button.innerHTML = "Inserisci"; - form.appendChild(dateInput); - form.appendChild(descrInput); - form.appendChild(button); - button.onclick = () => sendFormData("input_form", "insert_print"); - } - }); - } - }); + insertWork("insert_print"); } /* assigns a print to an operator */ @@ -186,45 +235,9 @@ function assignPrint() { /* completese a print */ function completePrint() { - clearPage(); - var form = document.getElementById("input_form"); - fetchData("prints", response => { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponse)) { - showClearElem(form.id); - var list = document.createElement("select"); - list.name = "print"; - list.id = "print_select"; - form.appendChild(list); - for (const index in jsonResponse) { - var elem = document.createElement("option"); - elem.value = jsonResponse[index]._printCodiceStampa; - elem.innerHTML = jsonResponse[index]._printCodiceStampa + " -- " + jsonResponse[index]._printDataRichiesta + " -- " + jsonResponse[index]._printCfRichiedente; - list.appendChild(elem); - } - form.appendChild(document.createElement("br")); - var totalInput = createTextInput("total", "Costo totale (usare . per i decimali)"); - var materialInput = createTextInput("materials", "Costo materiali (usare . per i decimali)"); - var timeInput = createTextInput("time", "Tempo di completamento in ore (usare . per i decimali)"); - var dateInput = document.createElement("input"); - dateInput.type = "date"; - dateInput.name = "date"; - dateInput.placeholder = "gg/mm/aaaa"; - var okButton = document.createElement("button"); - okButton.type = "button"; - okButton.innerHTML = "Modifica"; - okButton.onclick = () => sendFormData("input_form", "modify_print"); - form.append(totalInput, materialInput, timeInput, dateInput, document.createElement("br"), okButton); - } - }); - } - }); + completeWork("prints", "print", print => print._printCodiceStampa, + print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente), + "modify_print"); } /* assigns a filament to a print */ @@ -277,6 +290,7 @@ function showPrints() { + "
Tempo esecuzione: " + (print._printTempo == null ? "" : print._printTempo) + "
Codice fiscale incaricato: " + (print._printCfIncaricato == null ? "" : print._printCfIncaricato) + "
Codice stampante: " + (print._printCodiceStampante == null ? "" : print._printCodiceStampante) + + "
Descrizione: " + (print._printDescrizione == null ? "" : print._printDescrizione); descrDiv.appendChild(descrPar); codeCell.appendChild(descrDiv); listElem.append(codeCell, requestCell, completeCell, clientCell); @@ -854,6 +868,7 @@ function checkIfJsonIsError(json) { return json.hasOwnProperty("response"); } +/* function to create the form to assign an A element to a B element, using the given route */ function assignAToB(route, ARoute, BRoute, AName, BName, getACode, getAString, getBCode, getBString) { clearPage(); var form = document.getElementById("input_form"); @@ -911,4 +926,90 @@ function assignAToB(route, ARoute, BRoute, AName, BName, getACode, getAString, g }); } }); +} + +/* function to insert a new work into the given route (either a print or a cut) */ +function insertWork(route) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData("people", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var peopleList = document.createElement("select"); + peopleList.name = "client"; + peopleList.id = "client_select"; + form.appendChild(peopleList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = jsonResponse[index]._personCf; + elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; + peopleList.appendChild(elem); + } + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var descrInput = createTextInput("descr", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(dateInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", route); + } + }); + } + }); +} + +/* function to complete a work into the given route (either a print or a cut) */ +function completeWork(dataRoute, workType, workCode, workToString, insertRoute) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData(dataRoute, response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var list = document.createElement("select"); + list.name = workType; + list.id = workType + "_select"; + form.appendChild(list); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = workCode(jsonResponse[index]); + elem.innerHTML = workToString(jsonResponse[index]); + list.appendChild(elem); + } + form.appendChild(document.createElement("br")); + var totalInput = createTextInput("total", "Costo totale (usare . per i decimali)"); + var materialInput = createTextInput("materials", "Costo materiali (usare . per i decimali)"); + var timeInput = createTextInput("time", "Tempo di completamento in ore (usare . per i decimali)"); + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Modifica"; + okButton.onclick = () => sendFormData("input_form", insertRoute); + form.append(totalInput, materialInput, timeInput, dateInput, document.createElement("br"), okButton); + } + }); + } + }); } \ No newline at end of file From 5723d2c1fe79944db618bd5e7fcd8ec1769c5428 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 4 Oct 2019 09:03:26 +0200 Subject: [PATCH 53/73] Fix materials primary key --- src/Query.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Query.hs b/src/Query.hs index b12b83e..c46bb0c 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -218,7 +218,7 @@ insertMaterial code classCode name width descr = $ insertValues [ Material (pk mClass) - (prepareCode (classCode ++ code)) + (prepareCode (classCode ++ code ++ show width)) (prepareName name) width (pack descr) From 8b1060b9e336180dcbe2b832b731a99b519de14f Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 4 Oct 2019 19:21:25 +0200 Subject: [PATCH 54/73] Add db schema in sql format --- db_schema.sql | 666 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 666 insertions(+) create mode 100644 db_schema.sql diff --git a/db_schema.sql b/db_schema.sql new file mode 100644 index 0000000..b568e5a --- /dev/null +++ b/db_schema.sql @@ -0,0 +1,666 @@ +-- +-- PostgreSQL database dump +-- + +-- Dumped from database version 11.4 +-- Dumped by pg_dump version 11.4 + +-- Started on 2019-10-04 19:17:24 + +SET statement_timeout = 0; +SET lock_timeout = 0; +SET idle_in_transaction_session_timeout = 0; +SET client_encoding = 'UTF8'; +SET standard_conforming_strings = on; +SELECT pg_catalog.set_config('search_path', '', false); +SET check_function_bodies = false; +SET xmloption = content; +SET client_min_messages = warning; +SET row_security = off; + +-- +-- TOC entry 2 (class 3079 OID 16729) +-- Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: +-- + +CREATE EXTENSION IF NOT EXISTS "uuid-ossp" WITH SCHEMA public; + + +-- +-- TOC entry 2941 (class 0 OID 0) +-- Dependencies: 2 +-- Name: EXTENSION "uuid-ossp"; Type: COMMENT; Schema: -; Owner: +-- + +COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UUIDs)'; + + +SET default_tablespace = ''; + +SET default_with_oids = false; + +-- +-- TOC entry 198 (class 1259 OID 16456) +-- Name: classi_di_materiali; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.classi_di_materiali ( + codice_classe character(2) NOT NULL, + nome character varying(30) NOT NULL +); + + +ALTER TABLE public.classi_di_materiali OWNER TO postgres; + +-- +-- TOC entry 205 (class 1259 OID 16643) +-- Name: composizioni; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.composizioni ( + codice_lavorazione character(15) NOT NULL, + codice_intaglio integer NOT NULL +); + + +ALTER TABLE public.composizioni OWNER TO postgres; + +-- +-- TOC entry 207 (class 1259 OID 16663) +-- Name: filamenti; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.filamenti ( + codice_filamento character(7) NOT NULL, + codice_plastica character(3) NOT NULL, + marca character varying(30) NOT NULL, + colore character varying(30) NOT NULL +); + + +ALTER TABLE public.filamenti OWNER TO postgres; + +-- +-- TOC entry 203 (class 1259 OID 16593) +-- Name: intagli; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.intagli ( + codice_intaglio integer NOT NULL, + data_richiesta date NOT NULL, + data_consegna date, + tempo double precision, + costo_materiali numeric(6,2), + costo_totale numeric(6,2), + cf_richiedente character(16) NOT NULL, + cf_incaricato character(16), + descrizione character varying(400) NOT NULL, + CONSTRAINT date_intaglio CHECK ((data_richiesta <= data_consegna)), + CONSTRAINT tempo_intaglio CHECK ((tempo > (0)::double precision)) +); + + +ALTER TABLE public.intagli OWNER TO postgres; + +-- +-- TOC entry 210 (class 1259 OID 16722) +-- Name: intagli_codice_intaglio_seq; Type: SEQUENCE; Schema: public; Owner: postgres +-- + +ALTER TABLE public.intagli ALTER COLUMN codice_intaglio ADD GENERATED BY DEFAULT AS IDENTITY ( + SEQUENCE NAME public.intagli_codice_intaglio_seq + START WITH 0 + INCREMENT BY 1 + MINVALUE 0 + NO MAXVALUE + CACHE 1 +); + + +-- +-- TOC entry 202 (class 1259 OID 16561) +-- Name: lavorazioni; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.lavorazioni ( + codice_tipo character(3) NOT NULL, + codice_lavorazione character(15) NOT NULL, + codice_materiale character(4) NOT NULL, + potenza_massima integer NOT NULL, + potenza_minima integer NOT NULL, + velocita integer NOT NULL, + descrizione character varying(400) NOT NULL +); + + +ALTER TABLE public.lavorazioni OWNER TO postgres; + +-- +-- TOC entry 199 (class 1259 OID 16461) +-- Name: materiali; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.materiali ( + codice_classe character(2) NOT NULL, + codice_materiale character(6) NOT NULL, + nome character varying(30) NOT NULL, + spessore double precision NOT NULL, + descrizione character varying(400) NOT NULL +); + + +ALTER TABLE public.materiali OWNER TO postgres; + +-- +-- TOC entry 200 (class 1259 OID 16496) +-- Name: persone; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.persone ( + cf character(16) NOT NULL, + nome character varying(30) NOT NULL, + cognome character varying(30) NOT NULL, + socio boolean NOT NULL, + operatore_intagliatrice boolean NOT NULL, + operatore_stampante boolean NOT NULL, + spesa_totale numeric(6,2) NOT NULL, + CONSTRAINT abilitazioni CHECK (((socio = true) OR ((operatore_intagliatrice = false) AND (operatore_stampante = false)))) +); + + +ALTER TABLE public.persone OWNER TO postgres; + +-- +-- TOC entry 206 (class 1259 OID 16658) +-- Name: plastiche; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.plastiche ( + codice_plastica character(3) NOT NULL, + nome character varying(100) NOT NULL, + descrizione character varying(400) NOT NULL +); + + +ALTER TABLE public.plastiche OWNER TO postgres; + +-- +-- TOC entry 212 (class 1259 OID 16791) +-- Name: sessioni; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.sessioni ( + ora_creazione timestamp(6) with time zone NOT NULL, + id_sessione integer NOT NULL, + utente character varying(30) NOT NULL +); + + +ALTER TABLE public.sessioni OWNER TO postgres; + +-- +-- TOC entry 213 (class 1259 OID 16796) +-- Name: sessioni_id_sessione_seq; Type: SEQUENCE; Schema: public; Owner: postgres +-- + +ALTER TABLE public.sessioni ALTER COLUMN id_sessione ADD GENERATED BY DEFAULT AS IDENTITY ( + SEQUENCE NAME public.sessioni_id_sessione_seq + START WITH 0 + INCREMENT BY 1 + MINVALUE 0 + NO MAXVALUE + CACHE 1 +); + + +-- +-- TOC entry 197 (class 1259 OID 16451) +-- Name: stampanti; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.stampanti ( + codice_stampante character(3) NOT NULL, + marca character varying(30) NOT NULL, + modello character varying(30) NOT NULL, + descrizione character varying(400) NOT NULL +); + + +ALTER TABLE public.stampanti OWNER TO postgres; + +-- +-- TOC entry 204 (class 1259 OID 16616) +-- Name: stampe; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.stampe ( + codice_stampa integer NOT NULL, + data_richiesta date NOT NULL, + data_consegna date, + tempo double precision, + costo_materiali numeric(6,2), + costo_totale numeric(6,2), + descrizione character varying(400) NOT NULL, + cf_richiedente character(16) NOT NULL, + cf_incaricato character(16), + codice_stampante character(3), + CONSTRAINT date_stampe CHECK ((data_richiesta <= data_consegna)), + CONSTRAINT tempo_stampe CHECK ((tempo > (0)::double precision)) +); + + +ALTER TABLE public.stampe OWNER TO postgres; + +-- +-- TOC entry 209 (class 1259 OID 16720) +-- Name: stampe_codice_stampa_seq; Type: SEQUENCE; Schema: public; Owner: postgres +-- + +ALTER TABLE public.stampe ALTER COLUMN codice_stampa ADD GENERATED BY DEFAULT AS IDENTITY ( + SEQUENCE NAME public.stampe_codice_stampa_seq + START WITH 0 + INCREMENT BY 1 + MINVALUE 0 + NO MAXVALUE + CACHE 1 +); + + +-- +-- TOC entry 201 (class 1259 OID 16503) +-- Name: tipi; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.tipi ( + codice_tipo character(2) NOT NULL, + nome character varying(30) NOT NULL, + descrizione character varying(400) NOT NULL +); + + +ALTER TABLE public.tipi OWNER TO postgres; + +-- +-- TOC entry 208 (class 1259 OID 16675) +-- Name: usi; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.usi ( + codice_stampa integer NOT NULL, + codice_filamento character(7) NOT NULL +); + + +ALTER TABLE public.usi OWNER TO postgres; + +-- +-- TOC entry 211 (class 1259 OID 16786) +-- Name: utenti; Type: TABLE; Schema: public; Owner: postgres +-- + +CREATE TABLE public.utenti ( + username character varying(30) NOT NULL, + hash bytea NOT NULL, + admin boolean DEFAULT false NOT NULL +); + + +ALTER TABLE public.utenti OWNER TO postgres; + +-- +-- TOC entry 2798 (class 2606 OID 16790) +-- Name: utenti admins_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.utenti + ADD CONSTRAINT admins_pkey PRIMARY KEY (username); + + +-- +-- TOC entry 2772 (class 2606 OID 16509) +-- Name: classi_di_materiali classi di materiali_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.classi_di_materiali + ADD CONSTRAINT "classi di materiali_pkey" PRIMARY KEY (codice_classe); + + +-- +-- TOC entry 2788 (class 2606 OID 16647) +-- Name: composizioni composizioni_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.composizioni + ADD CONSTRAINT composizioni_pkey PRIMARY KEY (codice_lavorazione, codice_intaglio); + + +-- +-- TOC entry 2760 (class 2606 OID 16714) +-- Name: intagli consegna_intaglio; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.intagli + ADD CONSTRAINT consegna_intaglio CHECK (((data_consegna IS NULL) OR ((data_consegna IS NOT NULL) AND (costo_totale IS NOT NULL) AND (costo_materiali IS NOT NULL) AND (tempo IS NOT NULL) AND (cf_incaricato IS NOT NULL)))) NOT VALID; + + +-- +-- TOC entry 2764 (class 2606 OID 16702) +-- Name: stampe consegna_stampe; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.stampe + ADD CONSTRAINT consegna_stampe CHECK (((data_consegna IS NULL) OR ((data_consegna IS NOT NULL) AND (costo_totale IS NOT NULL) AND (costo_materiali IS NOT NULL) AND (tempo IS NOT NULL) AND (cf_incaricato IS NOT NULL) AND (codice_stampante IS NOT NULL)))) NOT VALID; + + +-- +-- TOC entry 2761 (class 2606 OID 16719) +-- Name: intagli costi_intaglio; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.intagli + ADD CONSTRAINT costi_intaglio CHECK (((costo_totale >= costo_materiali) AND (costo_materiali >= (0)::numeric))) NOT VALID; + + +-- +-- TOC entry 2765 (class 2606 OID 16707) +-- Name: stampe costi_stampe; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.stampe + ADD CONSTRAINT costi_stampe CHECK (((costo_totale >= costo_materiali) AND (costo_materiali >= (0)::numeric))) NOT VALID; + + +-- +-- TOC entry 2792 (class 2606 OID 16817) +-- Name: filamenti filamenti_codice_plastica_marca_colore_key; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.filamenti + ADD CONSTRAINT filamenti_codice_plastica_marca_colore_key UNIQUE (codice_plastica, marca, colore); + + +-- +-- TOC entry 2794 (class 2606 OID 16667) +-- Name: filamenti filamenti_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.filamenti + ADD CONSTRAINT filamenti_pkey PRIMARY KEY (codice_filamento); + + +-- +-- TOC entry 2784 (class 2606 OID 16601) +-- Name: intagli intagli_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.intagli + ADD CONSTRAINT intagli_pkey PRIMARY KEY (codice_intaglio); + + +-- +-- TOC entry 2757 (class 2606 OID 16584) +-- Name: lavorazioni intervallo_potenza_max; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.lavorazioni + ADD CONSTRAINT intervallo_potenza_max CHECK (((potenza_massima >= 0) AND (potenza_massima < 300))) NOT VALID; + + +-- +-- TOC entry 2758 (class 2606 OID 16585) +-- Name: lavorazioni intervallo_potenza_min; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.lavorazioni + ADD CONSTRAINT intervallo_potenza_min CHECK (((potenza_minima >= 0) AND (potenza_massima < 300))) NOT VALID; + + +-- +-- TOC entry 2759 (class 2606 OID 16586) +-- Name: lavorazioni intervallo_velocita; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.lavorazioni + ADD CONSTRAINT intervallo_velocita CHECK (((velocita > 0) AND (velocita < 300))) NOT VALID; + + +-- +-- TOC entry 2780 (class 2606 OID 16565) +-- Name: lavorazioni lavorazioni_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.lavorazioni + ADD CONSTRAINT lavorazioni_pkey PRIMARY KEY (codice_lavorazione); + + +-- +-- TOC entry 2782 (class 2606 OID 16573) +-- Name: lavorazioni lavorazioni_unique; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.lavorazioni + ADD CONSTRAINT lavorazioni_unique UNIQUE (codice_materiale, potenza_minima, potenza_massima, codice_tipo, velocita); + + +-- +-- TOC entry 2774 (class 2606 OID 16832) +-- Name: materiali materiali_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.materiali + ADD CONSTRAINT materiali_pkey PRIMARY KEY (codice_materiale); + + +-- +-- TOC entry 2776 (class 2606 OID 16502) +-- Name: persone persone_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.persone + ADD CONSTRAINT persone_pkey PRIMARY KEY (cf); + + +-- +-- TOC entry 2790 (class 2606 OID 16662) +-- Name: plastiche plastiche_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.plastiche + ADD CONSTRAINT plastiche_pkey PRIMARY KEY (codice_plastica); + + +-- +-- TOC entry 2800 (class 2606 OID 16799) +-- Name: sessioni sessioni_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.sessioni + ADD CONSTRAINT sessioni_pkey PRIMARY KEY (id_sessione); + + +-- +-- TOC entry 2756 (class 2606 OID 16694) +-- Name: persone spesa; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.persone + ADD CONSTRAINT spesa CHECK ((spesa_totale >= (0)::numeric)) NOT VALID; + + +-- +-- TOC entry 2754 (class 2606 OID 16560) +-- Name: materiali spessore_positivo; Type: CHECK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE public.materiali + ADD CONSTRAINT spessore_positivo CHECK ((spessore > (0)::double precision)) NOT VALID; + + +-- +-- TOC entry 2770 (class 2606 OID 16455) +-- Name: stampanti stampanti_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.stampanti + ADD CONSTRAINT stampanti_pkey PRIMARY KEY (codice_stampante); + + +-- +-- TOC entry 2786 (class 2606 OID 16624) +-- Name: stampe stampe_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.stampe + ADD CONSTRAINT stampe_pkey PRIMARY KEY (codice_stampa); + + +-- +-- TOC entry 2778 (class 2606 OID 16507) +-- Name: tipi tipi_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.tipi + ADD CONSTRAINT tipi_pkey PRIMARY KEY (codice_tipo); + + +-- +-- TOC entry 2796 (class 2606 OID 16679) +-- Name: usi usi_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.usi + ADD CONSTRAINT usi_pkey PRIMARY KEY (codice_stampa, codice_filamento); + + +-- +-- TOC entry 2801 (class 2606 OID 16510) +-- Name: materiali classe_materiale; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.materiali + ADD CONSTRAINT classe_materiale FOREIGN KEY (codice_classe) REFERENCES public.classi_di_materiali(codice_classe) ON DELETE CASCADE; + + +-- +-- TOC entry 2810 (class 2606 OID 16653) +-- Name: composizioni composizioni_codice_intaglio_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.composizioni + ADD CONSTRAINT composizioni_codice_intaglio_fkey FOREIGN KEY (codice_intaglio) REFERENCES public.intagli(codice_intaglio) ON DELETE CASCADE; + + +-- +-- TOC entry 2809 (class 2606 OID 16648) +-- Name: composizioni composizioni_codice_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.composizioni + ADD CONSTRAINT composizioni_codice_lavorazione_fkey FOREIGN KEY (codice_lavorazione) REFERENCES public.lavorazioni(codice_lavorazione) ON DELETE CASCADE; + + +-- +-- TOC entry 2811 (class 2606 OID 16818) +-- Name: filamenti filamenti_codice_plastica_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.filamenti + ADD CONSTRAINT filamenti_codice_plastica_fkey FOREIGN KEY (codice_plastica) REFERENCES public.plastiche(codice_plastica) ON DELETE CASCADE; + + +-- +-- TOC entry 2805 (class 2606 OID 16607) +-- Name: intagli incaricato_intaglio; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.intagli + ADD CONSTRAINT incaricato_intaglio FOREIGN KEY (cf_incaricato) REFERENCES public.persone(cf); + + +-- +-- TOC entry 2807 (class 2606 OID 16630) +-- Name: stampe incaricato_stampa; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.stampe + ADD CONSTRAINT incaricato_stampa FOREIGN KEY (cf_incaricato) REFERENCES public.persone(cf); + + +-- +-- TOC entry 2803 (class 2606 OID 16833) +-- Name: lavorazioni materiale_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.lavorazioni + ADD CONSTRAINT materiale_lavorazione_fkey FOREIGN KEY (codice_materiale) REFERENCES public.materiali(codice_materiale) ON DELETE CASCADE; + + +-- +-- TOC entry 2804 (class 2606 OID 16602) +-- Name: intagli richiedente_intaglio; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.intagli + ADD CONSTRAINT richiedente_intaglio FOREIGN KEY (cf_richiedente) REFERENCES public.persone(cf); + + +-- +-- TOC entry 2806 (class 2606 OID 16625) +-- Name: stampe richiedente_stampa; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.stampe + ADD CONSTRAINT richiedente_stampa FOREIGN KEY (cf_richiedente) REFERENCES public.persone(cf); + + +-- +-- TOC entry 2814 (class 2606 OID 16800) +-- Name: sessioni sessioni_admin_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.sessioni + ADD CONSTRAINT sessioni_admin_fkey FOREIGN KEY (utente) REFERENCES public.utenti(username); + + +-- +-- TOC entry 2808 (class 2606 OID 16635) +-- Name: stampe stampante; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.stampe + ADD CONSTRAINT stampante FOREIGN KEY (codice_stampante) REFERENCES public.stampanti(codice_stampante); + + +-- +-- TOC entry 2802 (class 2606 OID 16574) +-- Name: lavorazioni tipo_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.lavorazioni + ADD CONSTRAINT tipo_lavorazione_fkey FOREIGN KEY (codice_tipo) REFERENCES public.tipi(codice_tipo) ON DELETE CASCADE; + + +-- +-- TOC entry 2813 (class 2606 OID 16685) +-- Name: usi usi_codice_filamento_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.usi + ADD CONSTRAINT usi_codice_filamento_fkey FOREIGN KEY (codice_filamento) REFERENCES public.filamenti(codice_filamento); + + +-- +-- TOC entry 2812 (class 2606 OID 16680) +-- Name: usi usi_codice_stampa_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres +-- + +ALTER TABLE ONLY public.usi + ADD CONSTRAINT usi_codice_stampa_fkey FOREIGN KEY (codice_stampa) REFERENCES public.stampe(codice_stampa); + + +-- Completed on 2019-10-04 19:17:24 + +-- +-- PostgreSQL database dump complete +-- + From c815ac789cbc82eab60a1b4c7f62061829680515 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Fri, 4 Oct 2019 19:35:39 +0200 Subject: [PATCH 55/73] Fix db schema keys length --- db_schema.sql | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/db_schema.sql b/db_schema.sql index b568e5a..9aefa78 100644 --- a/db_schema.sql +++ b/db_schema.sql @@ -5,7 +5,7 @@ -- Dumped from database version 11.4 -- Dumped by pg_dump version 11.4 --- Started on 2019-10-04 19:17:24 +-- Started on 2019-10-04 19:35:15 SET statement_timeout = 0; SET lock_timeout = 0; @@ -58,7 +58,7 @@ ALTER TABLE public.classi_di_materiali OWNER TO postgres; -- CREATE TABLE public.composizioni ( - codice_lavorazione character(15) NOT NULL, + codice_lavorazione character(20) NOT NULL, codice_intaglio integer NOT NULL ); @@ -124,8 +124,8 @@ ALTER TABLE public.intagli ALTER COLUMN codice_intaglio ADD GENERATED BY DEFAULT CREATE TABLE public.lavorazioni ( codice_tipo character(3) NOT NULL, - codice_lavorazione character(15) NOT NULL, - codice_materiale character(4) NOT NULL, + codice_lavorazione character(20) NOT NULL, + codice_materiale character(8) NOT NULL, potenza_massima integer NOT NULL, potenza_minima integer NOT NULL, velocita integer NOT NULL, @@ -142,7 +142,7 @@ ALTER TABLE public.lavorazioni OWNER TO postgres; CREATE TABLE public.materiali ( codice_classe character(2) NOT NULL, - codice_materiale character(6) NOT NULL, + codice_materiale character(8) NOT NULL, nome character varying(30) NOT NULL, spessore double precision NOT NULL, descrizione character varying(400) NOT NULL @@ -326,7 +326,7 @@ ALTER TABLE ONLY public.classi_di_materiali -- --- TOC entry 2788 (class 2606 OID 16647) +-- TOC entry 2788 (class 2606 OID 16878) -- Name: composizioni composizioni_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres -- @@ -425,7 +425,7 @@ ALTER TABLE public.lavorazioni -- --- TOC entry 2780 (class 2606 OID 16565) +-- TOC entry 2780 (class 2606 OID 16866) -- Name: lavorazioni lavorazioni_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres -- @@ -434,7 +434,7 @@ ALTER TABLE ONLY public.lavorazioni -- --- TOC entry 2782 (class 2606 OID 16573) +-- TOC entry 2782 (class 2606 OID 16854) -- Name: lavorazioni lavorazioni_unique; Type: CONSTRAINT; Schema: public; Owner: postgres -- @@ -443,7 +443,7 @@ ALTER TABLE ONLY public.lavorazioni -- --- TOC entry 2774 (class 2606 OID 16832) +-- TOC entry 2774 (class 2606 OID 16843) -- Name: materiali materiali_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres -- @@ -551,7 +551,7 @@ ALTER TABLE ONLY public.composizioni -- --- TOC entry 2809 (class 2606 OID 16648) +-- TOC entry 2809 (class 2606 OID 16879) -- Name: composizioni composizioni_codice_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres -- @@ -587,7 +587,7 @@ ALTER TABLE ONLY public.stampe -- --- TOC entry 2803 (class 2606 OID 16833) +-- TOC entry 2803 (class 2606 OID 16855) -- Name: lavorazioni materiale_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres -- @@ -658,7 +658,7 @@ ALTER TABLE ONLY public.usi ADD CONSTRAINT usi_codice_stampa_fkey FOREIGN KEY (codice_stampa) REFERENCES public.stampe(codice_stampa); --- Completed on 2019-10-04 19:17:24 +-- Completed on 2019-10-04 19:35:16 -- -- PostgreSQL database dump complete From 3785db427af80eadcadf34141e1d4520a357a202 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 10:55:09 +0200 Subject: [PATCH 56/73] Fix db schema --- db_schema.sql | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/db_schema.sql b/db_schema.sql index 9aefa78..0c0c06a 100644 --- a/db_schema.sql +++ b/db_schema.sql @@ -5,7 +5,7 @@ -- Dumped from database version 11.4 -- Dumped by pg_dump version 11.4 --- Started on 2019-10-04 19:35:15 +-- Started on 2019-10-06 10:54:41 SET statement_timeout = 0; SET lock_timeout = 0; @@ -272,7 +272,7 @@ ALTER TABLE public.stampe ALTER COLUMN codice_stampa ADD GENERATED BY DEFAULT AS -- CREATE TABLE public.tipi ( - codice_tipo character(2) NOT NULL, + codice_tipo character(3) NOT NULL, nome character varying(30) NOT NULL, descrizione character varying(400) NOT NULL ); @@ -515,7 +515,7 @@ ALTER TABLE ONLY public.stampe -- --- TOC entry 2778 (class 2606 OID 16507) +-- TOC entry 2778 (class 2606 OID 16890) -- Name: tipi tipi_pkey; Type: CONSTRAINT; Schema: public; Owner: postgres -- @@ -587,7 +587,7 @@ ALTER TABLE ONLY public.stampe -- --- TOC entry 2803 (class 2606 OID 16855) +-- TOC entry 2802 (class 2606 OID 16855) -- Name: lavorazioni materiale_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres -- @@ -632,7 +632,7 @@ ALTER TABLE ONLY public.stampe -- --- TOC entry 2802 (class 2606 OID 16574) +-- TOC entry 2803 (class 2606 OID 16891) -- Name: lavorazioni tipo_lavorazione_fkey; Type: FK CONSTRAINT; Schema: public; Owner: postgres -- @@ -658,7 +658,7 @@ ALTER TABLE ONLY public.usi ADD CONSTRAINT usi_codice_stampa_fkey FOREIGN KEY (codice_stampa) REFERENCES public.stampe(codice_stampa); --- Completed on 2019-10-04 19:35:16 +-- Completed on 2019-10-06 10:54:41 -- -- PostgreSQL database dump complete From 40650fc7fc8f90e293c1e347674852124a3f9c98 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 10:58:47 +0200 Subject: [PATCH 57/73] Add some processings related functions --- client/index.js | 125 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 118 insertions(+), 7 deletions(-) diff --git a/client/index.js b/client/index.js index 8062336..26315cc 100644 --- a/client/index.js +++ b/client/index.js @@ -30,6 +30,7 @@ window.onload = function() { document.getElementById("show_filaments").onclick = () => showFilaments(); /* admins */ document.getElementById("insert_printer").onclick = () => insertPrinter(); + document.getElementById("insert_type").onclick = () => insertType(); } /* @@ -135,19 +136,19 @@ CUTS FUNCTIONS ---------------------------------------------------------------------------------------- */ -/* */ +/* creates the form and insert a new cut */ function insertCut() { insertWork("insert_cut"); } -/* */ +/* assigns a cut to an operator*/ function assignCut() { assignAToB("assign_cut_operator", "cuts", "cutterOperators", "cut", "operator", cut => cut._cutCodiceIntaglio, cut => (cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente), operator => operator._personCf, operator => (operator._personNome + " " + operator._personCognome + " -- " + operator._personCf)); } -/* */ +/* completes a cut*/ function completeCut() { completeWork("cuts", "cut", cut => cut._cutCodiceIntaglio, cut => (cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente), @@ -159,7 +160,7 @@ function assignProcessing() { } -/* */ +/* shows all the cuts in the database*/ function showCuts() { clearPage(); var form = document.getElementById("filters_form"); @@ -204,14 +205,106 @@ function showCuts() { setTable("cuts", resultTable, setter); } -/* */ +/* creates the form and inserts a new processing */ function insertProcessing() { - + clearPage(); + var form = document.getElementById("input_form"); + fetchData("types", responseTypes => { + if (responseTypes.ok) { + responseTypes.json().then(jsonResponseTypes => { + if (checkIfJsonIsError(jsonResponseTypes) && jsonResponseTypes["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseTypes["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseTypes)) { + fetchData("materials", responseMaterials => { + if (responseMaterials.ok) { + responseMaterials.json().then(jsonResponseMaterials => { + if (checkIfJsonIsError(jsonResponseMaterials) && jsonResponseMaterials["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseMaterials["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseMaterials)) { + showClearElem(form.id); + var typesList = document.createElement("select"); + typesList.name = "type"; + typesList.id = "type_select"; + form.appendChild(typesList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseTypes) { + var elem = document.createElement("option"); + elem.value = jsonResponseTypes[index]._typeCodiceTipo; + elem.innerHTML = jsonResponseTypes[index]._typeCodiceTipo + " " + jsonResponseTypes[index]._typeNome; + typesList.appendChild(elem); + } + var materialsTypes = document.createElement("select"); + materialsTypes.name = "material"; + materialsTypes.id = "material_select"; + form.appendChild(materialsTypes); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseMaterials) { + var elem = document.createElement("option"); + elem.value = jsonResponseMaterials[index]._materialCodiceMateriale; + elem.innerHTML = jsonResponseMaterials[index]._materialNome + " " + jsonResponseMaterials[index]._materialSpessore; + materialsTypes.appendChild(elem); + } + var maxPInput = createTextInput("max_potency", "Potenza massima"); + var minPInput = createTextInput("min_potency", "Potenze minima"); + var speedInput = createTextInput("speed", "Velocità"); + var descrInput = createTextInput("description", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.append(maxPInput, minPInput, speedInput, descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", "insert_processing"); + } + }); + } + }); + } + }); + } + }); } /* */ function showProcessings() { - + clearPage(); + var form = document.getElementById("filters_form"); + form.classList.remove("hidden"); + var resultTable = createTable("result_table", "headers", ["code", "Codice lavorazione"], ["description", "Descrizione"]); + document.getElementById("result_area").appendChild(resultTable); + var setter = (jsonResponse, table) => { + var body = table.getElementsByTagName("tbody")[0]; + showClearElem(body.id); + for (const index in jsonResponse) { + var listElem = document.createElement("tr"); + var processing = jsonResponse[index]; + listElem.classList.add("result_elem"); + var codeCell = document.createElement("td"); + codeCell.innerHTML = processing._processingCodiceLavorazione; + var descrCell = document.createElement("td"); + descrCell.innerHTML = processing._processingDescrizione; + var descrDiv = document.createElement("div"); + descrDiv.classList.add("complete_description"); + var descrPar = document.createElement("p"); + descrPar.innerHTML = "Codice lavorazione: " + processing._processingCodiceLavorazione + + "
Tipo: " + processing._processingCodiceTipo + + "
Materiale: " + processing._processingCodiceMateriale + + "
Potenza massima: " + processing._processingPotenzaMassima + + "
Potenza minima: " + processing._processingPotenzaMinima + + "
Velocità: " + processing._processingVelocita + + "
Descrizione: " + processing._processingDescrizione; + descrDiv.appendChild(descrPar); + codeCell.appendChild(descrDiv); + listElem.append(codeCell, descrCell); + body.appendChild(listElem); + } + }; + setTable("processings", resultTable, setter); } @@ -604,6 +697,24 @@ ADMIN FUNCTIONS ---------------------------------------------------------------------------------------- */ +/* creates the form and sends the data to insert a new type of processing in the database */ +function insertType() { + clearPage(); + var form = document.getElementById("input_form"); + showClearElem(form.id); + var codeInput = createTextInput("code", "Codice tipo di lavorazione (3 caratteri)"); + var nameInput = createTextInput("name", "Nome tipo di lavorazione"); + var descrInput = createTextInput("description", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(codeInput); + form.appendChild(nameInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", "insert_type"); +} + /* creates the form and insert a new printer in the database */ function insertPrinter() { clearPage(); From c746247d95534ab530e2d0d78408eb45abf44815 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:01:51 +0200 Subject: [PATCH 58/73] Add select_processings_by_material route --- src/Server.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Server.hs b/src/Server.hs index efc2e5f..99bbd07 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -323,6 +323,11 @@ app = do (read $ fromJust maybeSpeed :: Int) (fromJust maybeDescr) else missingParameter + post "select_processing_by_material" $ do + maybeMaterialCode <- param "material" + case maybeMaterialCode of + Nothing -> missingParameter + Just code -> executeQueryListAndSendResult $ selectProcessingsByMaterials code post "insert_plastic" $ do maybeCode <- param "code" maybeName <- param "name" From a3759136f383a46f14735ccf9fb5aba46e58b308 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:01:51 +0200 Subject: [PATCH 59/73] Add select_processings_by_material route --- src/Server.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Server.hs b/src/Server.hs index efc2e5f..60ee302 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -323,6 +323,11 @@ app = do (read $ fromJust maybeSpeed :: Int) (fromJust maybeDescr) else missingParameter + post "select_processings_by_material" $ do + maybeMaterialCode <- param "material" + case maybeMaterialCode of + Nothing -> missingParameter + Just code -> executeQueryListAndSendResult $ selectProcessingsByMaterials code post "insert_plastic" $ do maybeCode <- param "code" maybeName <- param "name" From 1816dc302bfb20d28df0a5c055d1206a5845858d Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:14:44 +0200 Subject: [PATCH 60/73] Fix selection of processings by material --- src/Server.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 60ee302..8ad77c7 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -323,11 +323,11 @@ app = do (read $ fromJust maybeSpeed :: Int) (fromJust maybeDescr) else missingParameter - post "select_processings_by_material" $ do - maybeMaterialCode <- param "material" - case maybeMaterialCode of - Nothing -> missingParameter - Just code -> executeQueryListAndSendResult $ selectProcessingsByMaterials code + post "select_processings_by_material" $ do + maybeMaterialCode <- param "material" + case maybeMaterialCode of + Nothing -> missingParameter + Just code -> executeQueryListAndSendResult $ selectProcessingsByMaterials code post "insert_plastic" $ do maybeCode <- param "code" maybeName <- param "name" From 95e8b04cadc300a6791e8a7d9f7e1b7d328e68fb Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:19:22 +0200 Subject: [PATCH 61/73] Complete show processings function --- client/index.js | 96 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 66 insertions(+), 30 deletions(-) diff --git a/client/index.js b/client/index.js index 26315cc..348ada0 100644 --- a/client/index.js +++ b/client/index.js @@ -157,7 +157,6 @@ function completeCut() { /* */ function assignProcessing() { - } /* shows all the cuts in the database*/ @@ -275,36 +274,73 @@ function showProcessings() { clearPage(); var form = document.getElementById("filters_form"); form.classList.remove("hidden"); - var resultTable = createTable("result_table", "headers", ["code", "Codice lavorazione"], ["description", "Descrizione"]); - document.getElementById("result_area").appendChild(resultTable); - var setter = (jsonResponse, table) => { - var body = table.getElementsByTagName("tbody")[0]; - showClearElem(body.id); - for (const index in jsonResponse) { - var listElem = document.createElement("tr"); - var processing = jsonResponse[index]; - listElem.classList.add("result_elem"); - var codeCell = document.createElement("td"); - codeCell.innerHTML = processing._processingCodiceLavorazione; - var descrCell = document.createElement("td"); - descrCell.innerHTML = processing._processingDescrizione; - var descrDiv = document.createElement("div"); - descrDiv.classList.add("complete_description"); - var descrPar = document.createElement("p"); - descrPar.innerHTML = "Codice lavorazione: " + processing._processingCodiceLavorazione - + "
Tipo: " + processing._processingCodiceTipo - + "
Materiale: " + processing._processingCodiceMateriale - + "
Potenza massima: " + processing._processingPotenzaMassima - + "
Potenza minima: " + processing._processingPotenzaMinima - + "
Velocità: " + processing._processingVelocita - + "
Descrizione: " + processing._processingDescrizione; - descrDiv.appendChild(descrPar); - codeCell.appendChild(descrDiv); - listElem.append(codeCell, descrCell); - body.appendChild(listElem); + fetchData("materials", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + var list = document.createElement("select"); + list.name = "material"; + list.id = "material_select"; + var elem = document.createElement("option"); + elem.value = "all"; + elem.innerHTML = "Tutti le lavorazioni"; + list.appendChild(elem); + form.appendChild(list); + for (const index in jsonResponse) { + elem = document.createElement("option"); + elem.value = jsonResponse[index]._materialCodiceMateriale + elem.innerHTML = jsonResponse[index]._materialCodiceClasse + " " + jsonResponse[index]._materialNome + " " + jsonResponse[index]._materialSpessore; + list.appendChild(elem); + } + var resultTable = createTable("result_table", "headers", ["code", "Codice lavorazione"], ["description", "Descrizione"]); + document.getElementById("result_area").appendChild(resultTable); + var setter = (jsonResponse, table) => { + var body = table.getElementsByTagName("tbody")[0]; + showClearElem(body.id); + for (const index in jsonResponse) { + var listElem = document.createElement("tr"); + var processing = jsonResponse[index]; + listElem.classList.add("result_elem"); + var codeCell = document.createElement("td"); + codeCell.innerHTML = processing._processingCodiceLavorazione; + var descrCell = document.createElement("td"); + descrCell.innerHTML = processing._processingDescrizione; + var descrDiv = document.createElement("div"); + descrDiv.classList.add("complete_description"); + var descrPar = document.createElement("p"); + descrPar.innerHTML = "Codice lavorazione: " + processing._processingCodiceLavorazione + + "
Tipo: " + processing._processingCodiceTipo + + "
Materiale: " + processing._processingCodiceMateriale + + "
Potenza massima: " + processing._processingPotenzaMassima + + "
Potenza minima: " + processing._processingPotenzaMinima + + "
Velocità: " + processing._processingVelocita + + "
Descrizione: " + processing._processingDescrizione; + descrDiv.appendChild(descrPar); + codeCell.appendChild(descrDiv); + listElem.append(codeCell, descrCell); + body.appendChild(listElem); + } + }; + var changer = () => { + if (list.value == "all") { + setTable("processings", resultTable, setter); + } else { + useChosenData("filters_form", "select_processings_by_material", data => { + setTableFromData(data, resultTable, setter); + }); + } + }; + changer(); + list.onchange = () => changer(); + } + }); } - }; - setTable("processings", resultTable, setter); + }); } From a12f484efd6c8eab17e3b4b661751860e2418119 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:32:09 +0200 Subject: [PATCH 62/73] Add alert for yet to be implemented functions --- client/index.css | 9 +++++++++ client/index.html | 2 ++ client/index.js | 31 ++++++++++++++++++++++++++++++- 3 files changed, 41 insertions(+), 1 deletion(-) diff --git a/client/index.css b/client/index.css index 8516afd..03e8534 100644 --- a/client/index.css +++ b/client/index.css @@ -144,6 +144,15 @@ button:hover { margin-left: -5px; margin-bottom: -15px; } +.alert { + color: #d30068; + width: 100%; + border: 0; + padding: 10px 0; + margin-top: 10px; + margin-left: -5px; + margin-bottom: 10px; +} .ok { color: #5f9900; width: 100%; diff --git a/client/index.html b/client/index.html index 2b3e41f..72ae1aa 100644 --- a/client/index.html +++ b/client/index.html @@ -26,6 +26,7 @@ + @@ -38,6 +39,7 @@ + diff --git a/client/index.js b/client/index.js index 348ada0..8e9f817 100644 --- a/client/index.js +++ b/client/index.js @@ -8,6 +8,7 @@ window.onload = function() { document.getElementById("assign_cut").onclick = () => assignCut(); document.getElementById("complete_cut").onclick = () => completeCut(); document.getElementById("assign_processing").onclick = () => assignProcessing(); + document.getElementById("show_assignments_cuts").onclick = () => showCutsAssignments(); document.getElementById("show_cuts").onclick = () => showCuts(); document.getElementById("insert_processing").onclick = () => insertProcessing(); document.getElementById("show_processings").onclick = () => showProcessings(); @@ -16,6 +17,7 @@ window.onload = function() { document.getElementById("assign_print").onclick = () => assignPrint(); document.getElementById("complete_print").onclick = () => completePrint(); document.getElementById("assign_filament").onclick = () => assignFilament(); + document.getElementById("show_assignments_prints").onclick = () => showPrintsAssignments(); document.getElementById("assign_printer").onclick = () => assignPrinter(); document.getElementById("show_prints").onclick = () => showPrints(); /* materials */ @@ -155,8 +157,16 @@ function completeCut() { "modify_cut"); } -/* */ +/* assigns a processing to a cut*/ function assignProcessing() { + // TODO: + showNotYetImplemented("result_area"); +} + +/* shows which processings are assigned to which cuts */ +function showCutsAssignments() { + // TODO: + showNotYetImplemented("result_area"); } /* shows all the cuts in the database*/ @@ -371,10 +381,20 @@ function completePrint() { /* assigns a filament to a print */ function assignFilament() { + // TODO: + showNotYetImplemented("result_area"); + /* assignAToB("assign_print_filament", "prints", "filaments", "print", "filament", print => print._printCodiceStampa, print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente), filament => filament._filamentCodiceFilamento, filament => (filament._filamentMarca + " " + filament._filamentColore)); + */ +} + +/* shows which filaments are assigned to which prints */ +function showPrintsAssignments() { + // TODO: + showNotYetImplemented("result_area"); } /* assigns a printer to a print */ @@ -1159,4 +1179,13 @@ function completeWork(dataRoute, workType, workCode, workToString, insertRoute) }); } }); +} + +function showNotYetImplemented(areaId) { + clearPage(); + var p = document.createElement("p"); + p.classList.add("alert"); + p.innerHTML = "Questa funzione sarà implementata a breve!"; + showClearElem(areaId); + document.getElementById(areaId).appendChild(p); } \ No newline at end of file From 2824cf4b5cb4ab2bdcbc134c0c9ddafd2bb9e2d0 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:42:42 +0200 Subject: [PATCH 63/73] Add function to register a new admin --- client/index.js | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/client/index.js b/client/index.js index 8e9f817..8164587 100644 --- a/client/index.js +++ b/client/index.js @@ -33,6 +33,7 @@ window.onload = function() { /* admins */ document.getElementById("insert_printer").onclick = () => insertPrinter(); document.getElementById("insert_type").onclick = () => insertType(); + document.getElementById("insert_admin").onclick = () => insertAdmin(); } /* @@ -791,6 +792,25 @@ function insertPrinter() { button.onclick = () => sendFormData("input_form", "insert_printer"); } +/* creates the form and insert a new admin in the database */ +function insertAdmin() { + clearPage(); + var form = document.getElementById("input_form"); + showClearElem(form.id); + var usernameInput = createTextInput("username", "Username"); + var passwordInput = document.createElement("input"); + passwordInput.type = "password"; + passwordInput.name = "password"; + passwordInput.placeholder = "Password"; + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(usernameInput); + form.appendChild(passwordInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", "insert_user"); +} + /* ---------------------------------------------------------------------------------------- GENERAL FUNCTIONS From 7afa79e4e13a628511999e0602cfc8deb3852f94 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 6 Oct 2019 11:47:14 +0200 Subject: [PATCH 64/73] Add routes for admin page --- client/manager.css | 0 client/manager.html | 0 client/manager.js | 0 src/Server.hs | 29 +++++++++++++++++++---------- 4 files changed, 19 insertions(+), 10 deletions(-) create mode 100644 client/manager.css create mode 100644 client/manager.html create mode 100644 client/manager.js diff --git a/client/manager.css b/client/manager.css new file mode 100644 index 0000000..e69de29 diff --git a/client/manager.html b/client/manager.html new file mode 100644 index 0000000..e69de29 diff --git a/client/manager.js b/client/manager.js new file mode 100644 index 0000000..e69de29 diff --git a/src/Server.hs b/src/Server.hs index 8ad77c7..67457f5 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -227,8 +227,9 @@ app = do middleware $ staticPolicy $ addBase "static" prehook baseHook $ do -- routes for unauthenticated users - get root $ do - file "text/html" $ getClientFilePath "login.html" + get root + $ file "text/html" + $ getClientFilePath "login.html" post "login" $ do maybeUser <- param "username" maybePswd <- param "password" @@ -246,8 +247,9 @@ app = do $ getClientFilePath "login.css" prehook authHook $ do -- routes for authenticated users - get "app" $ do - file "text/html" $ getClientFilePath "index.html" + get "app" + $ file "text/html" + $ getClientFilePath "index.html" post "insert_person" $ do maybeCf <- param "cf" maybeName <- param "name" @@ -404,7 +406,7 @@ app = do (read $ fromJust maybePrint :: Int) (read $ fromJust maybeDate :: Day) (read $ fromJust maybeTime :: Double) - (read $ fromJust maybeTotal :: Scientific) + (read $ fromJust maybeTotal :: Scientific) (read $ fromJust maybeMaterials :: Scientific) else missingParameter post "insert_cut" $ do @@ -429,7 +431,7 @@ app = do (read $ fromJust maybeCode :: Int) (fromJust maybeCf) else missingParameter - post "modify_cut" $ do + post "modify_cut" $ do maybeCut <- param "cut" maybeDate <- param "date" maybeTime <- param "time" @@ -442,7 +444,7 @@ app = do (read $ fromJust maybeCut :: Int) (read $ fromJust maybeDate :: Day) (read $ fromJust maybeTime :: Double) - (read $ fromJust maybeTotal :: Scientific) + (read $ fromJust maybeTotal :: Scientific) (read $ fromJust maybeMaterials :: Scientific) else missingParameter get "people" $ do @@ -482,13 +484,14 @@ app = do get "index.js" $ file "application/javascript" $ getClientFilePath "index.js" - get ("index.css") + get "index.css" $ file "text/css" $ getClientFilePath "index.css" prehook adminHook $ do -- routes for authenticated admins - get "manager" $ do - text "with great power comes great responsability!" + get "manager" + $ file "text/html" + $ getClientFilePath "manager.html" post "insert_type" $ do maybeCode <- param "code" maybeName <- param "name" @@ -525,6 +528,12 @@ app = do (fromJust maybeUser) (fromJust maybePswd) else messageJson 401 "Parametro mancante" + get "manager.js" + $ file "application/javascript" + $ getClientFilePath "manager.js" + get "manager.css" + $ file "text/css" + $ getClientFilePath "manager.css" -- orphan istances (argh) because they are not necessary for the db part of the application, only for the server one deriving instance FromJSON Person From bd0d84690af7e544cfa9dda4fdbc34e33ee1afb4 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Tue, 8 Oct 2019 09:14:58 +0200 Subject: [PATCH 65/73] Restructure admin and common user pages, insert no_auth page --- .vscode/settings.json | 4 + client/common.js | 398 ++++++++++++++++++++++++++++++++++++ client/index.css | 20 +- client/index.html | 26 ++- client/index.js | 466 ------------------------------------------ client/login.css | 27 ++- client/manager.css | 1 + client/manager.html | 31 +++ client/manager.js | 68 ++++++ client/no_auth.html | 16 ++ src/Server.hs | 10 +- 11 files changed, 581 insertions(+), 486 deletions(-) create mode 100644 .vscode/settings.json create mode 100644 client/common.js create mode 100644 client/no_auth.html diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..f429a43 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,4 @@ +{ + "editor.fontFamily": "iosevka", + "editor.fontLigatures": true +} \ No newline at end of file diff --git a/client/common.js b/client/common.js new file mode 100644 index 0000000..62febc6 --- /dev/null +++ b/client/common.js @@ -0,0 +1,398 @@ +/* +---------------------------------------------------------------------------------------- +GENERAL FUNCTIONS +---------------------------------------------------------------------------------------- +*/ + +/* fetches data from the given route, and executes the given action */ +function fetchData(route, action) { + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(action); +} + +/* sets the content of the "result_area" element with the results from the given route inserted in the given table by the tableSetter */ +function setTable(route, table, tableSetter) { + fetchData(route, function(response) { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + showClearElem("result_area"); + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + resultDiv.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + setTableFromData(jsonResponse, table, tableSetter); + } + }); + } + }); +} + +/* sets the content of the "result_area" element with the given data, inserted in the given table by the tableSetter */ +function setTableFromData(data, table, tableSetter) { + var resultDiv = document.getElementById("result_area"); + document.getElementById("result_area").classList.remove("hidden"); + tableSetter(data, table); + resultDiv.appendChild(table); +} + +/* clears the page */ +function clearPage() { + var hideableElements = document.getElementsByClassName("hideable"); + for (var i = 0; i < hideableElements.length; i++) { + hideableElements[i].classList.add("hidden"); + while (hideableElements[i].firstChild) { + hideableElements[i].removeChild(hideableElements[i].firstChild); + } + } +} + +/* makes visible the element with elemId, as if it was created anew */ +function showClearElem(elemId) { + var elem = document.getElementById(elemId); + if (elem != null) { + while(elem.firstChild) { + elem.removeChild(elem.firstChild); + } + elem.classList.remove("hidden"); + } +} + +/* creates a variable number of radio buttons into the form, for the table with the given tableSetter, with [name, label, route] properties */ +function createFiltersRadioButtons(form, table, tableSetter, name, ...radioButtons) { + radioButtons.forEach(button => { + var input = document.createElement("input"); + var label = document.createElement("label"); + input.type = "radio"; + input.name = name; + input.id = button[0]; + input.onclick = () => { if (input.checked) { setTable(button[2], table, tableSetter); } }; + label.for = input.id; + label.innerHTML = button[1]; + form.appendChild(input); + form.appendChild(label); + form.appendChild(document.createElement("br")); + }); +} + +/* creates a variable number of checkBoxes into the form, with [name, value, label] properties */ +function createFiltersCheckBoxes(form, ...checkBoxes) { + checkBoxes.forEach(box => { + var input = document.createElement("input"); + var label = document.createElement("label"); + input.type = "checkbox"; + input.name = box[0]; + input.value = box[1]; + input.id = box[0]; + label.for = input.id; + label.innerHTML = box[2]; + form.appendChild(input); + form.appendChild(label); + form.appendChild(document.createElement("br")); + }); +} + +/* creates a variable number of checkBoxes into the form, with [name, value, label] properties, that have the "hidden" class */ +function createHiddenFiltersCheckBoxes(form, ...checkBoxes) { + checkBoxes.forEach(box => { + var input = document.createElement("input"); + input.type = "checkbox"; + input.name = box[0]; + input.value = box[1]; + input.checked = true; + input.id = box[0] + "_hidden"; + input.classList.add("hidden"); + form.appendChild(input); + }); +} + +/* change the checked boxes based on the value of the "cf_select" element */ +function changeCheckedBoxes() { + var list = document.getElementById("cf_select"); + fetchData("people", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (!checkIfJsonIsError(jsonResponse)) { + for (const index in jsonResponse) { + if (list.value == jsonResponse[index]._personCf) { + document.getElementById("partner").checked = jsonResponse[index]._personSocio; + document.getElementById("cutter").checked = jsonResponse[index]._personOperatoreIntagliatrice; + document.getElementById("printer").checked = jsonResponse[index]._personOperatoreStampante; + } + } + } + }); + } + }); +} + +/* disables the invisibles checkboxes if the visible ones are checked */ +function disableCheckBoxes(form) { + var checkBoxes = document.getElementsByTagName("input"); + for (const index in checkBoxes) { + var box = checkBoxes.item(index); + if (box.type == "checkbox" && box.classList.contains("hidden")) { + var shownId = box.id.split("_")[0]; + var shownBox = document.getElementById(shownId); + if (shownBox.checked) { + box.disabled = true; + } + } + } +} + +/* sends to the said route the content of the given form, giving a visual notice of the result of the operation */ +function sendFormData(formId, route) { + var form = document.getElementById(formId); + var fd = new FormData(form); + var post = { + method: "POST", + body: fd + }; + var errors = form.getElementsByClassName("error"); + while (errors.length > 0) { + errors.item(0).parentNode.removeChild(errors.item(0)); + } + var oks = form.getElementsByClassName("ok"); + while (oks.length > 0) { + oks.item(0).parentNode.removeChild(oks.item(0)); + } + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route, post).then(function(response) { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] == "200") { + var ok = document.createElement("P"); + ok.innerHTML = jsonResponse["response"]["message"]; + ok.classList.add("ok"); + form.appendChild(ok); + } + }); + } + }); +} + +/* sends to the said route the content of the given form, doing something with the results */ +function useChosenData(formId, route, action) { + var form = document.getElementById(formId); + var fd = new FormData(form); + var post = { + method: "POST", + body: fd + }; + var errors = form.getElementsByClassName("error"); + while (errors.length > 0) { + errors.item(0).parentNode.removeChild(errors.item(0)); + } + var oks = form.getElementsByClassName("ok"); + while (oks.length > 0) { + oks.item(0).parentNode.removeChild(oks.item(0)); + } + fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route, post).then(function(response) { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse)) { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else { + action(jsonResponse); + } + }); + } + }); +} + +/* creates a text input, with the given name and placeholder */ +function createTextInput(name, placeholder) { + var input = document.createElement("input"); + input.type = "text"; + input.name = name; + input.placeholder = placeholder; + return input; +} + +/* creates a table with the given id, id of the headers and columns [headerId, name] */ +function createTable(tableId, headersId, ...headers) { + var resultTable = document.createElement("table"); + resultTable.id = tableId; + var head = document.createElement("thead"); + var body = document.createElement("tbody"); + body.id = "table_body"; + var header = document.createElement("tr"); + head.appendChild(header); + header.id = headersId; + resultTable.appendChild(head); + headers.forEach(h => { + var th = document.createElement("th"); + th.id = h[0]; + th.innerHTML = h[1]; + header.appendChild(th); + }); + resultTable.appendChild(body); + return resultTable; +} + +function checkIfJsonIsError(json) { + return json.hasOwnProperty("response"); +} + +/* function to create the form to assign an A element to a B element, using the given route */ +function assignAToB(route, ARoute, BRoute, AName, BName, getACode, getAString, getBCode, getBString) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData(ARoute, responseA => { + if (responseA.ok) { + responseA.json().then(jsonResponseA => { + if (checkIfJsonIsError(jsonResponseA) && jsonResponseA["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseA["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseA)) { + fetchData(BRoute, responseB => { + if (responseB.ok) { + responseB.json().then(jsonResponseB => { + if (checkIfJsonIsError(jsonResponseB) && jsonResponseB["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponseB["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponseB)) { + showClearElem(form.id); + var AList = document.createElement("select"); + AList.name = AName; + AList.id = AName + "_select"; + form.appendChild(AList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseA) { + var elem = document.createElement("option"); + elem.value = getACode(jsonResponseA[index]); + elem.innerHTML = getAString(jsonResponseA[index]); + AList.appendChild(elem); + } + var BList = document.createElement("select"); + BList.name = BName; + BList.id = BName + "_select"; + form.appendChild(BList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponseB) { + var elem = document.createElement("option"); + elem.value = getBCode(jsonResponseB[index]); + elem.innerHTML = getBString(jsonResponseB[index]); + BList.appendChild(elem); + } + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Assegna"; + okButton.onclick = () => sendFormData("input_form", route); + form.appendChild(okButton); + } + }); + } + }); + } + }); + } + }); +} + +/* function to insert a new work into the given route (either a print or a cut) */ +function insertWork(route) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData("people", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var peopleList = document.createElement("select"); + peopleList.name = "client"; + peopleList.id = "client_select"; + form.appendChild(peopleList); + form.appendChild(document.createElement("br")); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = jsonResponse[index]._personCf; + elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; + peopleList.appendChild(elem); + } + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var descrInput = createTextInput("descr", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(dateInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => sendFormData("input_form", route); + } + }); + } + }); +} + +/* function to complete a work into the given route (either a print or a cut) */ +function completeWork(dataRoute, workType, workCode, workToString, insertRoute) { + clearPage(); + var form = document.getElementById("input_form"); + fetchData(dataRoute, response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + showClearElem(form.id); + var list = document.createElement("select"); + list.name = workType; + list.id = workType + "_select"; + form.appendChild(list); + for (const index in jsonResponse) { + var elem = document.createElement("option"); + elem.value = workCode(jsonResponse[index]); + elem.innerHTML = workToString(jsonResponse[index]); + list.appendChild(elem); + } + form.appendChild(document.createElement("br")); + var totalInput = createTextInput("total", "Costo totale (usare . per i decimali)"); + var materialInput = createTextInput("materials", "Costo materiali (usare . per i decimali)"); + var timeInput = createTextInput("time", "Tempo di completamento in ore (usare . per i decimali)"); + var dateInput = document.createElement("input"); + dateInput.type = "date"; + dateInput.name = "date"; + dateInput.placeholder = "gg/mm/aaaa"; + var okButton = document.createElement("button"); + okButton.type = "button"; + okButton.innerHTML = "Modifica"; + okButton.onclick = () => sendFormData("input_form", insertRoute); + form.append(totalInput, materialInput, timeInput, dateInput, document.createElement("br"), okButton); + } + }); + } + }); +} + +function showNotYetImplemented(areaId) { + clearPage(); + var p = document.createElement("p"); + p.classList.add("alert"); + p.innerHTML = "Questa funzione sarà implementata a breve!"; + showClearElem(areaId); + document.getElementById(areaId).appendChild(p); +} \ No newline at end of file diff --git a/client/index.css b/client/index.css index 03e8534..1933519 100644 --- a/client/index.css +++ b/client/index.css @@ -28,6 +28,21 @@ body { .scrollable { /* padding-top: 2.5%; */ } +footer { + position: fixed; + left: 0; + bottom: 0; + width: 99%; + text-align: right; +} +footer > p > a { + text-decoration: none; + background: #e969a8; + color: #890043; + padding: 5px 5px; + border-radius: 3px; + box-shadow: 0 1px 3px 0 rgba(211, 0, 104, 0.12), 0 1px 2px 0 rgba(233, 58, 144, 0.24); +} .menu { background-color: #e969a8; color: #890043; @@ -87,14 +102,13 @@ body { padding: 10px 20px 30px 30px; border-radius: 10px; position: absolute; - top: 20%; + top: 15%; left: 10%; width: 80%; } #input_form.hidden { display: none; } - #input_form { overflow: hidden; background-color: white; @@ -164,7 +178,7 @@ button:hover { } #result { - margin: 10px; + margin: 3%; } #filters_form.hidden { diff --git a/client/index.html b/client/index.html index 72ae1aa..eff95e5 100644 --- a/client/index.html +++ b/client/index.html @@ -1,14 +1,15 @@ - + - + + Menù -
+
-
-
+ +
@@ -81,7 +74,12 @@
-
+ + \ No newline at end of file diff --git a/client/index.js b/client/index.js index 8164587..5ead178 100644 --- a/client/index.js +++ b/client/index.js @@ -30,10 +30,6 @@ window.onload = function() { document.getElementById("insert_filament").onclick = () => insertFilament(); document.getElementById("show_plastics").onclick = () => showPlastics(); document.getElementById("show_filaments").onclick = () => showFilaments(); - /* admins */ - document.getElementById("insert_printer").onclick = () => insertPrinter(); - document.getElementById("insert_type").onclick = () => insertType(); - document.getElementById("insert_admin").onclick = () => insertAdmin(); } /* @@ -746,466 +742,4 @@ function showPlastics() { table.appendChild(listElem); } }); -} - -/* ----------------------------------------------------------------------------------------- -ADMIN FUNCTIONS ----------------------------------------------------------------------------------------- -*/ - -/* creates the form and sends the data to insert a new type of processing in the database */ -function insertType() { - clearPage(); - var form = document.getElementById("input_form"); - showClearElem(form.id); - var codeInput = createTextInput("code", "Codice tipo di lavorazione (3 caratteri)"); - var nameInput = createTextInput("name", "Nome tipo di lavorazione"); - var descrInput = createTextInput("description", "Descrizione"); - var button = document.createElement("button"); - button.type = "button"; - button.innerHTML = "Inserisci"; - form.appendChild(codeInput); - form.appendChild(nameInput); - form.appendChild(descrInput); - form.appendChild(button); - button.onclick = () => sendFormData("input_form", "insert_type"); -} - -/* creates the form and insert a new printer in the database */ -function insertPrinter() { - clearPage(); - var form = document.getElementById("input_form"); - showClearElem(form.id); - var codeInput = createTextInput("code", "Codice stampante (3 caratteri)"); - var brandInput = createTextInput("brand", "Marca"); - var modelInput = createTextInput("model", "Modello"); - var descrInput = createTextInput("description", "Descrizione"); - var button = document.createElement("button"); - button.type = "button"; - button.innerHTML = "Inserisci"; - form.appendChild(codeInput); - form.appendChild(brandInput); - form.appendChild(modelInput); - form.appendChild(descrInput); - form.appendChild(button); - button.onclick = () => sendFormData("input_form", "insert_printer"); -} - -/* creates the form and insert a new admin in the database */ -function insertAdmin() { - clearPage(); - var form = document.getElementById("input_form"); - showClearElem(form.id); - var usernameInput = createTextInput("username", "Username"); - var passwordInput = document.createElement("input"); - passwordInput.type = "password"; - passwordInput.name = "password"; - passwordInput.placeholder = "Password"; - var button = document.createElement("button"); - button.type = "button"; - button.innerHTML = "Inserisci"; - form.appendChild(usernameInput); - form.appendChild(passwordInput); - form.appendChild(button); - button.onclick = () => sendFormData("input_form", "insert_user"); -} - -/* ----------------------------------------------------------------------------------------- -GENERAL FUNCTIONS ----------------------------------------------------------------------------------------- -*/ - -/* fetches data from the given route, and executes the given action */ -function fetchData(route, action) { - fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route).then(action); -} - -/* sets the content of the "result_area" element with the results from the given route inserted in the given table by the tableSetter */ -function setTable(route, table, tableSetter) { - fetchData(route, function(response) { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - showClearElem("result_area"); - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - resultDiv.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponse)) { - setTableFromData(jsonResponse, table, tableSetter); - } - }); - } - }); -} - -/* sets the content of the "result_area" element with the given data, inserted in the given table by the tableSetter */ -function setTableFromData(data, table, tableSetter) { - var resultDiv = document.getElementById("result_area"); - document.getElementById("result_area").classList.remove("hidden"); - tableSetter(data, table); - resultDiv.appendChild(table); -} - -/* clears the page */ -function clearPage() { - var hideableElements = document.getElementsByClassName("hideable"); - for (var i = 0; i < hideableElements.length; i++) { - hideableElements[i].classList.add("hidden"); - while (hideableElements[i].firstChild) { - hideableElements[i].removeChild(hideableElements[i].firstChild); - } - } -} - -/* makes visible the element with elemId, as if it was created anew */ -function showClearElem(elemId) { - var elem = document.getElementById(elemId); - if (elem != null) { - while(elem.firstChild) { - elem.removeChild(elem.firstChild); - } - elem.classList.remove("hidden"); - } -} - -/* creates a variable number of radio buttons into the form, for the table with the given tableSetter, with [name, label, route] properties */ -function createFiltersRadioButtons(form, table, tableSetter, name, ...radioButtons) { - radioButtons.forEach(button => { - var input = document.createElement("input"); - var label = document.createElement("label"); - input.type = "radio"; - input.name = name; - input.id = button[0]; - input.onclick = () => { if (input.checked) { setTable(button[2], table, tableSetter); } }; - label.for = input.id; - label.innerHTML = button[1]; - form.appendChild(input); - form.appendChild(label); - form.appendChild(document.createElement("br")); - }); -} - -/* creates a variable number of checkBoxes into the form, with [name, value, label] properties */ -function createFiltersCheckBoxes(form, ...checkBoxes) { - checkBoxes.forEach(box => { - var input = document.createElement("input"); - var label = document.createElement("label"); - input.type = "checkbox"; - input.name = box[0]; - input.value = box[1]; - input.id = box[0]; - label.for = input.id; - label.innerHTML = box[2]; - form.appendChild(input); - form.appendChild(label); - form.appendChild(document.createElement("br")); - }); -} - -/* creates a variable number of checkBoxes into the form, with [name, value, label] properties, that have the "hidden" class */ -function createHiddenFiltersCheckBoxes(form, ...checkBoxes) { - checkBoxes.forEach(box => { - var input = document.createElement("input"); - input.type = "checkbox"; - input.name = box[0]; - input.value = box[1]; - input.checked = true; - input.id = box[0] + "_hidden"; - input.classList.add("hidden"); - form.appendChild(input); - }); -} - -/* change the checked boxes based on the value of the "cf_select" element */ -function changeCheckedBoxes() { - var list = document.getElementById("cf_select"); - fetchData("people", response => { - if (response.ok) { - response.json().then(jsonResponse => { - if (!checkIfJsonIsError(jsonResponse)) { - for (const index in jsonResponse) { - if (list.value == jsonResponse[index]._personCf) { - document.getElementById("partner").checked = jsonResponse[index]._personSocio; - document.getElementById("cutter").checked = jsonResponse[index]._personOperatoreIntagliatrice; - document.getElementById("printer").checked = jsonResponse[index]._personOperatoreStampante; - } - } - } - }); - } - }); -} - -/* disables the invisibles checkboxes if the visible ones are checked */ -function disableCheckBoxes(form) { - var checkBoxes = document.getElementsByTagName("input"); - for (const index in checkBoxes) { - var box = checkBoxes.item(index); - if (box.type == "checkbox" && box.classList.contains("hidden")) { - var shownId = box.id.split("_")[0]; - var shownBox = document.getElementById(shownId); - if (shownBox.checked) { - box.disabled = true; - } - } - } -} - -/* sends to the said route the content of the given form, giving a visual notice of the result of the operation */ -function sendFormData(formId, route) { - var form = document.getElementById(formId); - var fd = new FormData(form); - var post = { - method: "POST", - body: fd - }; - var errors = form.getElementsByClassName("error"); - while (errors.length > 0) { - errors.item(0).parentNode.removeChild(errors.item(0)); - } - var oks = form.getElementsByClassName("ok"); - while (oks.length > 0) { - oks.item(0).parentNode.removeChild(oks.item(0)); - } - fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route, post).then(function(response) { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] == "200") { - var ok = document.createElement("P"); - ok.innerHTML = jsonResponse["response"]["message"]; - ok.classList.add("ok"); - form.appendChild(ok); - } - }); - } - }); -} - -/* sends to the said route the content of the given form, doing something with the results */ -function useChosenData(formId, route, action) { - var form = document.getElementById(formId); - var fd = new FormData(form); - var post = { - method: "POST", - body: fd - }; - var errors = form.getElementsByClassName("error"); - while (errors.length > 0) { - errors.item(0).parentNode.removeChild(errors.item(0)); - } - var oks = form.getElementsByClassName("ok"); - while (oks.length > 0) { - oks.item(0).parentNode.removeChild(oks.item(0)); - } - fetch(window.location.protocol + "//" + window.location.host.toString() + "/" + route, post).then(function(response) { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse)) { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else { - action(jsonResponse); - } - }); - } - }); -} - -/* creates a text input, with the given name and placeholder */ -function createTextInput(name, placeholder) { - var input = document.createElement("input"); - input.type = "text"; - input.name = name; - input.placeholder = placeholder; - return input; -} - -/* creates a table with the given id, id of the headers and columns [headerId, name] */ -function createTable(tableId, headersId, ...headers) { - var resultTable = document.createElement("table"); - resultTable.id = tableId; - var head = document.createElement("thead"); - var body = document.createElement("tbody"); - body.id = "table_body"; - var header = document.createElement("tr"); - head.appendChild(header); - header.id = headersId; - resultTable.appendChild(head); - headers.forEach(h => { - var th = document.createElement("th"); - th.id = h[0]; - th.innerHTML = h[1]; - header.appendChild(th); - }); - resultTable.appendChild(body); - return resultTable; -} - -function checkIfJsonIsError(json) { - return json.hasOwnProperty("response"); -} - -/* function to create the form to assign an A element to a B element, using the given route */ -function assignAToB(route, ARoute, BRoute, AName, BName, getACode, getAString, getBCode, getBString) { - clearPage(); - var form = document.getElementById("input_form"); - fetchData(ARoute, responseA => { - if (responseA.ok) { - responseA.json().then(jsonResponseA => { - if (checkIfJsonIsError(jsonResponseA) && jsonResponseA["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponseA["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponseA)) { - fetchData(BRoute, responseB => { - if (responseB.ok) { - responseB.json().then(jsonResponseB => { - if (checkIfJsonIsError(jsonResponseB) && jsonResponseB["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponseB["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponseB)) { - showClearElem(form.id); - var AList = document.createElement("select"); - AList.name = AName; - AList.id = AName + "_select"; - form.appendChild(AList); - form.appendChild(document.createElement("br")); - for (const index in jsonResponseA) { - var elem = document.createElement("option"); - elem.value = getACode(jsonResponseA[index]); - elem.innerHTML = getAString(jsonResponseA[index]); - AList.appendChild(elem); - } - var BList = document.createElement("select"); - BList.name = BName; - BList.id = BName + "_select"; - form.appendChild(BList); - form.appendChild(document.createElement("br")); - for (const index in jsonResponseB) { - var elem = document.createElement("option"); - elem.value = getBCode(jsonResponseB[index]); - elem.innerHTML = getBString(jsonResponseB[index]); - BList.appendChild(elem); - } - var okButton = document.createElement("button"); - okButton.type = "button"; - okButton.innerHTML = "Assegna"; - okButton.onclick = () => sendFormData("input_form", route); - form.appendChild(okButton); - } - }); - } - }); - } - }); - } - }); -} - -/* function to insert a new work into the given route (either a print or a cut) */ -function insertWork(route) { - clearPage(); - var form = document.getElementById("input_form"); - fetchData("people", response => { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponse)) { - showClearElem(form.id); - var peopleList = document.createElement("select"); - peopleList.name = "client"; - peopleList.id = "client_select"; - form.appendChild(peopleList); - form.appendChild(document.createElement("br")); - for (const index in jsonResponse) { - var elem = document.createElement("option"); - elem.value = jsonResponse[index]._personCf; - elem.innerHTML = jsonResponse[index]._personNome + " " + jsonResponse[index]._personCognome + " -- " + jsonResponse[index]._personCf; - peopleList.appendChild(elem); - } - var dateInput = document.createElement("input"); - dateInput.type = "date"; - dateInput.name = "date"; - dateInput.placeholder = "gg/mm/aaaa"; - var descrInput = createTextInput("descr", "Descrizione"); - var button = document.createElement("button"); - button.type = "button"; - button.innerHTML = "Inserisci"; - form.appendChild(dateInput); - form.appendChild(descrInput); - form.appendChild(button); - button.onclick = () => sendFormData("input_form", route); - } - }); - } - }); -} - -/* function to complete a work into the given route (either a print or a cut) */ -function completeWork(dataRoute, workType, workCode, workToString, insertRoute) { - clearPage(); - var form = document.getElementById("input_form"); - fetchData(dataRoute, response => { - if (response.ok) { - response.json().then(jsonResponse => { - if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { - var error = document.createElement("P"); - error.innerHTML = jsonResponse["response"]["message"]; - error.classList.add("error"); - form.appendChild(error); - } else if (!checkIfJsonIsError(jsonResponse)) { - showClearElem(form.id); - var list = document.createElement("select"); - list.name = workType; - list.id = workType + "_select"; - form.appendChild(list); - for (const index in jsonResponse) { - var elem = document.createElement("option"); - elem.value = workCode(jsonResponse[index]); - elem.innerHTML = workToString(jsonResponse[index]); - list.appendChild(elem); - } - form.appendChild(document.createElement("br")); - var totalInput = createTextInput("total", "Costo totale (usare . per i decimali)"); - var materialInput = createTextInput("materials", "Costo materiali (usare . per i decimali)"); - var timeInput = createTextInput("time", "Tempo di completamento in ore (usare . per i decimali)"); - var dateInput = document.createElement("input"); - dateInput.type = "date"; - dateInput.name = "date"; - dateInput.placeholder = "gg/mm/aaaa"; - var okButton = document.createElement("button"); - okButton.type = "button"; - okButton.innerHTML = "Modifica"; - okButton.onclick = () => sendFormData("input_form", insertRoute); - form.append(totalInput, materialInput, timeInput, dateInput, document.createElement("br"), okButton); - } - }); - } - }); -} - -function showNotYetImplemented(areaId) { - clearPage(); - var p = document.createElement("p"); - p.classList.add("alert"); - p.innerHTML = "Questa funzione sarà implementata a breve!"; - showClearElem(areaId); - document.getElementById(areaId).appendChild(p); } \ No newline at end of file diff --git a/client/login.css b/client/login.css index 1a3a693..b95ee39 100644 --- a/client/login.css +++ b/client/login.css @@ -14,7 +14,7 @@ body { background-color: #c2f56e; font-family: 'Asap', sans-serif; } -#login_form { +#login_form, section { overflow: hidden; background-color: white; padding: 10px 20px 30px 30px; @@ -27,6 +27,10 @@ body { transition: transform 300ms, box-shadow 300ms; box-shadow: 3px 3px 3px #e93a90; } +section { + text-align: center; + width: 30%; +} #login_form::before, #login_form::after { content: ''; position: absolute; @@ -96,3 +100,24 @@ button:hover { transform: rotate(360deg); } } +section > h1 { + font-family: 'Asap', sans-serif; + font-size: 28px; + color: #142114; + padding: 10px 10px; +} +a { + text-decoration: none; + font-family: 'Asap', sans-serif; + cursor: pointer; + color: #5f9900; + font-size: 16px; + text-transform: uppercase; + width: auto; + border: 0; + padding: 8px 5px 8px 5px; + margin-top: 10px; + margin-left: -5px; + border-radius: 5px; + background-color: #c2f56e; +} diff --git a/client/manager.css b/client/manager.css index e69de29..11296d3 100644 --- a/client/manager.css +++ b/client/manager.css @@ -0,0 +1 @@ +@import "index.css" \ No newline at end of file diff --git a/client/manager.html b/client/manager.html index e69de29..67faeb2 100644 --- a/client/manager.html +++ b/client/manager.html @@ -0,0 +1,31 @@ + + + + + + + + Menù admin + + +
+ +
+
+
+ +
+
+ + + \ No newline at end of file diff --git a/client/manager.js b/client/manager.js index e69de29..fd58e3a 100644 --- a/client/manager.js +++ b/client/manager.js @@ -0,0 +1,68 @@ +window.onload = () => { + document.getElementById("insert_printer").onclick = () => insertPrinter(); + document.getElementById("insert_type").onclick = () => insertType(); + document.getElementById("insert_admin").onclick = () => insertAdmin(); +} + +/* +---------------------------------------------------------------------------------------- +ADMIN FUNCTIONS +---------------------------------------------------------------------------------------- +*/ + +/* creates the form and sends the data to insert a new type of processing in the database */ +function insertType() { + /* c. */clearPage(); + var form = document.getElementById("input_form"); + /* c. */showClearElem(form.id); + var codeInput = /* c. */createTextInput("code", "Codice tipo di lavorazione (3 caratteri)"); + var nameInput = /* c. */createTextInput("name", "Nome tipo di lavorazione"); + var descrInput = /* c. */createTextInput("description", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(codeInput); + form.appendChild(nameInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => /* c. */sendFormData("input_form", "insert_type"); +} + +/* creates the form and insert a new printer in the database */ +function insertPrinter() { + /* c. */clearPage(); + var form = document.getElementById("input_form"); + /* c. */showClearElem(form.id); + var codeInput = /* c. */createTextInput("code", "Codice stampante (3 caratteri)"); + var brandInput = /* c. */createTextInput("brand", "Marca"); + var modelInput = /* c. */createTextInput("model", "Modello"); + var descrInput = /* c. */createTextInput("description", "Descrizione"); + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(codeInput); + form.appendChild(brandInput); + form.appendChild(modelInput); + form.appendChild(descrInput); + form.appendChild(button); + button.onclick = () => /* c. */sendFormData("input_form", "insert_printer"); +} + +/* creates the form and insert a new admin in the database */ +function insertAdmin() { + /* c. */clearPage(); + var form = document.getElementById("input_form"); + /* c. */showClearElem(form.id); + var usernameInput = /* c. */createTextInput("username", "Username"); + var passwordInput = document.createElement("input"); + passwordInput.type = "password"; + passwordInput.name = "password"; + passwordInput.placeholder = "Password"; + var button = document.createElement("button"); + button.type = "button"; + button.innerHTML = "Inserisci"; + form.appendChild(usernameInput); + form.appendChild(passwordInput); + form.appendChild(button); + button.onclick = () => /* c. */sendFormData("input_form", "insert_user"); +} \ No newline at end of file diff --git a/client/no_auth.html b/client/no_auth.html new file mode 100644 index 0000000..fa97784 --- /dev/null +++ b/client/no_auth.html @@ -0,0 +1,16 @@ + + + + + + Login + + + +
+

Non sei autorizzato!

+ Vai al login +
+ + + \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index 67457f5..6303f3f 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -115,7 +115,7 @@ authHook = do sess <- readSession mUser <- getUserFromSession case mUser of - Nothing -> messageJson 401 "Utente non autorizzato" + Nothing -> redirect "no_auth" -- messageJson 401 "Admin non autorizzato" Just val -> return (val :&: oldCtx) -- |Admin authorization level @@ -129,7 +129,7 @@ adminHook = do Just user -> case _userAdmin user of True -> return (user :&: oldCtx) - False -> messageJson 401 "Admin non autorizzato" + False -> redirect "no_auth" --messageJson 401 "Admin non autorizzato" -- |Function to get the user of the current session getUserFromSession :: ActionCtxT ctx (WebStateM Connection SessionVal st) (Maybe User) @@ -230,6 +230,9 @@ app = do get root $ file "text/html" $ getClientFilePath "login.html" + get "no_auth" + $ file "text/html" + $ getClientFilePath "no_auth.html" post "login" $ do maybeUser <- param "username" maybePswd <- param "password" @@ -487,6 +490,9 @@ app = do get "index.css" $ file "text/css" $ getClientFilePath "index.css" + get "common.js" + $ file "application/javascript" + $ getClientFilePath "common.js" prehook adminHook $ do -- routes for authenticated admins get "manager" From bb7d153960009151e169c5d4d98f617d7064407c Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 9 Oct 2019 11:18:16 +0200 Subject: [PATCH 66/73] Minor change to GUI --- client/index.js | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/client/index.js b/client/index.js index 5ead178..3df977f 100644 --- a/client/index.js +++ b/client/index.js @@ -479,7 +479,7 @@ function insertMaterial() { } var materialCode = createTextInput("code", "Codice materiale (2 caratteri)"); var nameInput = createTextInput("name", "Nome"); - var widthInput = createTextInput("width", "Spessore"); + var widthInput = createTextInput("width", "Spessore (mm)"); var descrInput = createTextInput("description", "Descrizione"); var okButton = document.createElement("button"); okButton.type = "button"; @@ -536,7 +536,7 @@ function showMaterials() { elem.innerHTML = jsonResponse[index]._materialsclassCodiceClasse + " -- " + jsonResponse[index]._materialsclassNome; list.appendChild(elem); } - var resultTable = createTable("result_table", "headers", ["code", "Codice"], ["class", "Classe"], ["name", "Nome"], ["width", "Spessore"], ["description", "Descrizione"]); + var resultTable = createTable("result_table", "headers", ["code", "Codice"], ["class", "Classe"], ["name", "Nome"], ["width", "Spessore (mm)"], ["description", "Descrizione"]); var setter = (jsonResponse, table) => { var body = table.getElementsByTagName("tbody")[0]; showClearElem(body.id); From 0836ae190dfd72b226bb793c78ecf39b43110881 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 9 Oct 2019 11:19:22 +0200 Subject: [PATCH 67/73] Update readme file --- .gitignore | 3 ++- README.md | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 52 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index efe515a..4870095 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .stack-work/ haskellDB.cabal *~ -*.lock \ No newline at end of file +*.lock +*.cfg \ No newline at end of file diff --git a/README.md b/README.md index a296404..011e213 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,52 @@ # haskellDB -An application aiming to provide access to a database for Maker Station \ No newline at end of file +An application aiming to provide a (not so) easy way to manage the works commissioned to Maker Station. + +It's a lovely mix of Haskell, HTML, Javascript and CSS. + +## How to make it work + +### Requirements: +- PostgreSQL 11.5 +- GHCI >= 8.6.5 +- Stack +- Internet browser of your choice + +### Preparation: +- Install the softwares listed above +- Clone this repository +- Use "db_schema.sql" to generate the database (use pgAdmin, or whatever tool you are most comfortable with) +- Create a file named "server.cfg" in the repository directory, containing the following lines: + ``` + db="name_of_your_db" + dbLocation="localhost" + dbPort=5432 + dbUser="your_db_user" + dbPswd="your_db_user_password" + port=8080 + apiName="MSManager" + ``` + Changes could be necessary, depending on your postgres installation and necessities. +- Move to the repository directory on the command line +- Use `stack ghci` + +The following steps are needed to create the first admin user. + +- In the GHCI prompt use `connectWithInfo "localhost" 5432 "your_db_user" "your_db_user_password" "name_of_your_db" >>= insertUser "username" "password"`, changing the function arguments with the ones yuo need and wish to use. +- Open pgAdmin (or whatever tool you use to execute queries in the database) and execute the query `UPDATE utenti SET admin = true WHERE username = 'username'`, changing username with the one chosen in the previous step. + +You have now created your first admin user! + +- Return to the GHCI prompt, use `main` +- Open your browser, and connect to `localhost:8080` + - The web interface was tested on Firefox, but it should work on other browsers too (please, avoid Internet Explorer) +- That's it. Log in, and everything should work! + +## A little disclaimer +- This system doesn't aim to be safe: at the moment, I don't have the knowledge to make it safe. So, it isn't. Don't use as if it were. In particular, the main problems are: + - the database password is saved in a plain-text file. I think it's pretty clear why that's bad + - knowing that, notice that the users' data is at risk, too + - there is no safe connection to the server (no https), so your passwords are sent without encryption +- This is not easy to install, and some operations are doable only through SQL queries: again, I have neither the knowledge nor the time to resolve this +- The user interface is probably badly written, and not accessible: I'm still learning, and I will (probably) correct it in the future +- The Haskell code works, but it could be better: I repeat, I'm still learning \ No newline at end of file From 8fb3af714fff62e4e70e7904aa8492499c9b5964 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 9 Oct 2019 11:55:05 +0200 Subject: [PATCH 68/73] Add functionalities for tracking use of processings and filaments --- src/Query.hs | 30 ++++++++++++++++++++++++++++++ src/Server.hs | 30 ++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) diff --git a/src/Query.hs b/src/Query.hs index c46bb0c..2d8df9d 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -496,6 +496,22 @@ assignFilament pCode fCode = } ] +-- |Selects the filaments assigned to the given print +assignmentsByPrint :: Int -> (Connection -> IO (Either SqlError [Use])) +assignmentsByPrint pCode = + \conn -> do + selectedPrint <- selectPrintFromCode pCode conn + case selectedPrint of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No print with the given code was present" "" "" + Right (Just p) -> + try + $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\u -> _useCodiceStampa u ==. val_ (pk p)) + $ allElementsOfTable _usi + -- |Complete a print completePrint :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completePrint pCode deliveryDate workTime total materials = @@ -614,6 +630,20 @@ assignProcessing cCode pCode = } ] +-- |Selects the filaments assigned to the given cut +assignmentsByCut :: Int -> (Connection -> IO (Either SqlError [Composition])) +assignmentsByCut cCode = + \conn -> do + selectedCut <- selectCutFromCode cCode conn + case selectedCut of + Left ex -> return $ Left ex + Right Nothing -> return $ Left $ SqlError "" NonfatalError "No cut with the given code was present" "" "" + Right (Just cut) -> try $ runBeam conn + $ runSelectReturningList + $ select + $ filter_ (\c -> _compositionCodiceIntaglio c ==. val_ (pk cut)) + $ allElementsOfTable _composizioni + -- |Complete a cut completeCut :: Int -> Day -> Double -> Scientific -> Scientific -> (Connection -> IO (Either SqlError ())) completeCut code deliveryDate workTime total materials = diff --git a/src/Server.hs b/src/Server.hs index 6303f3f..1405bfc 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -333,6 +333,21 @@ app = do case maybeMaterialCode of Nothing -> missingParameter Just code -> executeQueryListAndSendResult $ selectProcessingsByMaterials code + post "assign_cut_processing" $ do + maybeCut <- param "cut" + maybeProcessing <- param "processing" + if testParameters [maybeCut, maybeProcessing] + then + executeModifyQueryAndSendResult + $ assignProcessing + (read $ fromJust maybeCut :: Int) + (fromJust maybeProcessing) + else missingParameter + post "assignments_cut" $ do + maybeCut <- param "cut" + case maybeCut of + Nothing -> missingParameter + Just cut -> executeQueryListAndSendResult $ assignmentsByCut (read $ cut :: Int) post "insert_plastic" $ do maybeCode <- param "code" maybeName <- param "name" @@ -396,6 +411,21 @@ app = do (fromJust maybeCodePrinter) (read $ fromJust maybeCode :: Int) else missingParameter + post "assign_print_filament" $ do + maybePrint <- param "print" + maybeFilament <- param "filament" + if testParameters [maybePrint, maybeFilament] + then + executeModifyQueryAndSendResult + $ assignFilament + (read $ fromJust maybePrint :: Int) + (fromJust maybeFilament) + else missingParameter + post "assignments_print" $ do + maybePrint <- param "print" + case maybePrint of + Nothing -> missingParameter + Just p -> executeQueryListAndSendResult $ assignmentsByCut (read $ p :: Int) post "modify_print" $ do maybePrint <- param "print" maybeDate <- param "date" From 106fd901eed28882f03e4a8d8863b3c7356ab241 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 9 Oct 2019 12:15:09 +0200 Subject: [PATCH 69/73] Fix assignments_print route --- src/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index 1405bfc..a8feb36 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -425,7 +425,7 @@ app = do maybePrint <- param "print" case maybePrint of Nothing -> missingParameter - Just p -> executeQueryListAndSendResult $ assignmentsByCut (read $ p :: Int) + Just p -> executeQueryListAndSendResult $ assignmentsByPrint (read $ p :: Int) post "modify_print" $ do maybePrint <- param "print" maybeDate <- param "date" From 28d169ab0ff2c4de6a7521284996b83034794ca5 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 9 Oct 2019 12:17:11 +0200 Subject: [PATCH 70/73] Add functions for assignments of processings and cuts --- client/index.js | 127 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 117 insertions(+), 10 deletions(-) diff --git a/client/index.js b/client/index.js index 3df977f..386356a 100644 --- a/client/index.js +++ b/client/index.js @@ -156,14 +156,70 @@ function completeCut() { /* assigns a processing to a cut*/ function assignProcessing() { - // TODO: - showNotYetImplemented("result_area"); + assignAToB("assign_cut_processing", "cuts", "processings", "cut", "processing", + cut => cut._cutCodiceIntaglio, cut => (cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente), + processing => processing._processingCodiceLavorazione, processing => processing._processingCodiceLavorazione); } /* shows which processings are assigned to which cuts */ function showCutsAssignments() { - // TODO: - showNotYetImplemented("result_area"); + clearPage(); + var form = document.getElementById("filters_form"); + form.classList.remove("hidden"); + fetchData("cuts", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + var list = document.createElement("select"); + list.name = "cut"; + list.id = "cut_select"; + var elem = document.createElement("option"); + elem.value = "none"; + elem.innerHTML = ""; + list.appendChild(elem); + form.appendChild(list); + for (const index in jsonResponse) { + var cut = jsonResponse[index]; + elem = document.createElement("option"); + elem.value = cut._cutCodiceIntaglio + elem.innerHTML = cut._cutCodiceIntaglio + " -- " + cut._cutDataRichiesta + " -- " + cut._cutCfRichiedente; + list.appendChild(elem); + } + var resultTable = createTable("result_table", "headers", ["code", "Codice lavorazione"]); + document.getElementById("result_area").appendChild(resultTable); + var setter = (jsonResponse, table) => { + var body = table.getElementsByTagName("tbody")[0]; + showClearElem(body.id); + for (const index in jsonResponse) { + var listElem = document.createElement("tr"); + var composition = jsonResponse[index]; + listElem.classList.add("result_elem"); + var codeCell = document.createElement("td"); + codeCell.innerHTML = composition._compositionCodiceLavorazione; + listElem.append(codeCell); + body.appendChild(listElem); + } + }; + var changer = () => { + if (list.value == "none") { + setTableFromData([], resultTable, setter); + } else { + useChosenData("filters_form", "assignments_cut", data => { + setTableFromData(data, resultTable, setter); + }); + } + }; + changer(); + list.onchange = () => changer(); + } + }); + } + }); } /* shows all the cuts in the database*/ @@ -378,20 +434,71 @@ function completePrint() { /* assigns a filament to a print */ function assignFilament() { - // TODO: - showNotYetImplemented("result_area"); - /* assignAToB("assign_print_filament", "prints", "filaments", "print", "filament", print => print._printCodiceStampa, print => (print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente), filament => filament._filamentCodiceFilamento, filament => (filament._filamentMarca + " " + filament._filamentColore)); - */ } /* shows which filaments are assigned to which prints */ function showPrintsAssignments() { - // TODO: - showNotYetImplemented("result_area"); + clearPage(); + var form = document.getElementById("filters_form"); + form.classList.remove("hidden"); + fetchData("prints", response => { + if (response.ok) { + response.json().then(jsonResponse => { + if (checkIfJsonIsError(jsonResponse) && jsonResponse["response"]["code"] != "200") { + var error = document.createElement("P"); + error.innerHTML = jsonResponse["response"]["message"]; + error.classList.add("error"); + form.appendChild(error); + } else if (!checkIfJsonIsError(jsonResponse)) { + var list = document.createElement("select"); + list.name = "print"; + list.id = "print_select"; + var elem = document.createElement("option"); + elem.value = "none"; + elem.innerHTML = ""; + list.appendChild(elem); + form.appendChild(list); + for (const index in jsonResponse) { + var print = jsonResponse[index]; + elem = document.createElement("option"); + elem.value = print._printCodiceStampa + elem.innerHTML = print._printCodiceStampa + " -- " + print._printDataRichiesta + " -- " + print._printCfRichiedente; + list.appendChild(elem); + } + var resultTable = createTable("result_table", "headers", ["code", "Codice filamento"]); + document.getElementById("result_area").appendChild(resultTable); + var setter = (jsonResponse, table) => { + var body = table.getElementsByTagName("tbody")[0]; + showClearElem(body.id); + for (const index in jsonResponse) { + var listElem = document.createElement("tr"); + var use = jsonResponse[index]; + listElem.classList.add("result_elem"); + var codeCell = document.createElement("td"); + codeCell.innerHTML = use._useCodiceFilamento; + listElem.append(codeCell); + body.appendChild(listElem); + } + }; + var changer = () => { + if (list.value == "none") { + setTableFromData([], resultTable, setter); + } else { + useChosenData("filters_form", "assignments_print", data => { + setTableFromData(data, resultTable, setter); + }); + } + }; + changer(); + list.onchange = () => changer(); + } + }); + } + }); } /* assigns a printer to a print */ From 20990223ab6f27a24dff09afdfecd98a339f34c1 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Tue, 22 Oct 2019 09:44:34 +0200 Subject: [PATCH 71/73] Fix select tag behaviour --- client/common.js | 8 ++++++++ client/index.css | 4 +++- client/index.html | 4 ++-- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/client/common.js b/client/common.js index 62febc6..1e18d14 100644 --- a/client/common.js +++ b/client/common.js @@ -45,6 +45,10 @@ function clearPage() { hideableElements[i].removeChild(hideableElements[i].firstChild); } } + var groupHideableElements = document.getElementsByClassName("group_hideable"); + for (var i = 0; i < groupHideableElements.length; i++) { + groupHideableElements[i].classList.add("hidden"); + } } /* makes visible the element with elemId, as if it was created anew */ @@ -55,6 +59,10 @@ function showClearElem(elemId) { elem.removeChild(elem.firstChild); } elem.classList.remove("hidden"); + while (elem.parentElement) { + elem.parentElement.classList.remove("hidden"); + elem = elem.parentElement; + } } } diff --git a/client/index.css b/client/index.css index 1933519..2417ba2 100644 --- a/client/index.css +++ b/client/index.css @@ -282,13 +282,15 @@ td { select { font-family: 'Asap', sans-serif; font-size: 16px; + width: 100%; color: #142114; padding: 2px; border-radius: 3px; border-color: #c2f56e; - -moz-appearance: none; + cursor: pointer; display: inline-block; margin: 10px 10px 10px 0px; + box-shadow: 2px 2px 2px 2px rgba(126, 177, 44, 0.12), 0 2px 3px 0 rgba(126, 177, 44, 0.24); } input[type="checkbox"].hidden { display: none; diff --git a/client/index.html b/client/index.html index eff95e5..14cb2a6 100644 --- a/client/index.html +++ b/client/index.html @@ -67,10 +67,10 @@
-
+ -
+ From e1ccbecc41ca35b1393ddf81ebc64288b3388aaa Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Sun, 3 Nov 2019 18:31:05 +0100 Subject: [PATCH 72/73] Change to how the database password is managed, update changelog and readme --- ChangeLog.md | 18 ++++++++++++++++++ README.md | 8 +++----- app/Main.hs | 18 ++++++++++++++++-- package.yaml | 1 + src/Server.hs | 11 +++++------ 5 files changed, 43 insertions(+), 13 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 266afbe..fc57a6a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,21 @@ # Changelog for haskellDB ## Unreleased changes + +## [V0.1] - 2019/10/09 +### Added +- First working version of the software! + +## [V0.2] - 2019/10/22 +### Added +- Functions for tracking use of processings and filaments + +### Fixed +- Dropdown menu behaviour in the client interface + +## [V0.3] - 2019/11/03 +### Added +- This CHANGELOG + +### Changed +- There is no more need for storing passwords in plain text! Check the README for more info! diff --git a/README.md b/README.md index 011e213..c22f1df 100644 --- a/README.md +++ b/README.md @@ -22,7 +22,6 @@ It's a lovely mix of Haskell, HTML, Javascript and CSS. dbLocation="localhost" dbPort=5432 dbUser="your_db_user" - dbPswd="your_db_user_password" port=8080 apiName="MSManager" ``` @@ -32,20 +31,19 @@ It's a lovely mix of Haskell, HTML, Javascript and CSS. The following steps are needed to create the first admin user. -- In the GHCI prompt use `connectWithInfo "localhost" 5432 "your_db_user" "your_db_user_password" "name_of_your_db" >>= insertUser "username" "password"`, changing the function arguments with the ones yuo need and wish to use. +- In the GHCI prompt use `connectWithInfo "localhost" 5432 "your_db_user" "your_db_user_password" "name_of_your_db" >>= insertUser "username" "password"`, changing the function arguments with the ones you need and wish to use. - Open pgAdmin (or whatever tool you use to execute queries in the database) and execute the query `UPDATE utenti SET admin = true WHERE username = 'username'`, changing username with the one chosen in the previous step. You have now created your first admin user! -- Return to the GHCI prompt, use `main` +- Return to the GHCI prompt, use `:main PASSWORD`, where PASSWORD is the password of the PostgreSQL user you used in the "server.cfg" file + - If you wish to execute the server outside of the GHCI prompt (and that would be great!) use Stack to build and install the application, and call it from the command line with PASSWORD as the first argument - Open your browser, and connect to `localhost:8080` - The web interface was tested on Firefox, but it should work on other browsers too (please, avoid Internet Explorer) - That's it. Log in, and everything should work! ## A little disclaimer - This system doesn't aim to be safe: at the moment, I don't have the knowledge to make it safe. So, it isn't. Don't use as if it were. In particular, the main problems are: - - the database password is saved in a plain-text file. I think it's pretty clear why that's bad - - knowing that, notice that the users' data is at risk, too - there is no safe connection to the server (no https), so your passwords are sent without encryption - This is not easy to install, and some operations are doable only through SQL queries: again, I have neither the knowledge nor the time to resolve this - The user interface is probably badly written, and not accessible: I'm still learning, and I will (probably) correct it in the future diff --git a/app/Main.hs b/app/Main.hs index a7f1eb4..8477c45 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,12 +2,26 @@ module Main where +import Data.Semigroup ((<>)) +import Options.Applicative +import Query import Schema import Server -import Query configFile :: FilePath configFile = "server.cfg" +passwordParser :: Parser String +passwordParser = argument str (metavar "PASSWORD") + +pswdInfo :: ParserInfo String +pswdInfo = + info (passwordParser <**> helper) + ( fullDesc + <> progDesc "Starts the server application using the PASSWORD for connecting to the database" + ) + main :: IO () -main = parseConfig configFile >>= runServer +main = do + pswd <- execParser pswdInfo + parseConfig configFile >>= (flip runServer pswd) diff --git a/package.yaml b/package.yaml index 10d0d46..d009a6f 100644 --- a/package.yaml +++ b/package.yaml @@ -30,6 +30,7 @@ dependencies: - hvect - memory - mtl +- optparse-applicative - postgresql-libpq - scientific - Spock >= 0.11 diff --git a/src/Server.hs b/src/Server.hs index a8feb36..a3dfd08 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -42,7 +42,6 @@ data ApiCfg acfg_db_location :: Text, acfg_db_port :: Integer, acfg_db_user :: Text, - acfg_db_pswd :: Text, acfg_port :: Int, acfg_name :: Text } @@ -72,10 +71,9 @@ parseConfig cfgFile = do dbLocation <- C.require cfg "dbLocation" dbPort <- C.require cfg "dbPort" dbUser <- C.require cfg "dbUser" - dbPassword <- C.require cfg "dbPswd" port <- C.require cfg "port" name <- C.require cfg "apiName" - return (ApiCfg db dbLocation dbPort dbUser dbPassword port name) + return (ApiCfg db dbLocation dbPort dbUser port name) -- |Function used to get the connection used to interrogate the database getFabLabConnection @@ -210,13 +208,14 @@ missingParameter :: MonadIO m => ActionCtxT ctx m b missingParameter = messageJson 422 "Parametro mancante" -- server functions -runServer :: ApiCfg -> IO () -runServer cfg = +-- |Runs the server using the given configuration and the password for the database +runServer :: ApiCfg -> String -> IO () +runServer cfg pswd = let ioConn = getFabLabConnection (unpack $ acfg_db_location cfg) (acfg_db_port cfg) (unpack $ acfg_db_user cfg) - (unpack $ acfg_db_pswd cfg) + pswd (unpack $ acfg_db cfg) in do spockCfg <- defaultSpockCfg Nothing (getPoolOrConn ioConn) () From 92492f9368a3e768c7d89d7183ca4b6de45024d2 Mon Sep 17 00:00:00 2001 From: Giorgia Rondinini Date: Wed, 20 Nov 2019 10:37:13 +0100 Subject: [PATCH 73/73] Fix cut operator assignment --- src/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index a3dfd08..5cd2f16 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -455,7 +455,7 @@ app = do else missingParameter post "assign_cut_operator" $ do maybeCf <- param "operator" - maybeCode <- param "print" + maybeCode <- param "cut" if testParameters [maybeCode, maybeCf] then executeModifyQueryAndSendResult